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 )
23 defaultErrorHandler defaultDynFlags $ do
24 runGhc (Just libdir) $ do
25 dflags <- getSessionDynFlags
26 setSessionDynFlags dflags
27 --target <- guessTarget "adder.hs" Nothing
28 --liftIO (print (showSDoc (ppr (target))))
29 --liftIO $ printTarget target
32 --core <- GHC.compileToCoreSimplified "Adders.hs"
33 core <- GHC.compileToCoreSimplified "Adders.hs"
34 liftIO $ printBinds (cm_binds core)
35 let bind = findBind "half_adder" (cm_binds core)
36 let NonRec var expr = bind
37 liftIO $ putStr $ showSDoc $ ppr expr
38 liftIO $ putStr "\n\n"
39 liftIO $ putStr $ getArchitecture bind
42 printTarget (Target (TargetFile file (Just x)) obj Nothing) =
45 printBinds [] = putStr "done\n\n"
46 printBinds (b:bs) = do
51 printBind (NonRec b expr) = do
55 printBind (Rec binds) = do
57 foldl1 (>>) (map printBind' binds)
59 printBind' (b, expr) = do
60 putStr $ getOccString b
61 --putStr $ showSDoc $ ppr expr
64 findBind :: String -> [CoreBind] -> CoreBind
66 -- This ignores Recs and compares the name of the bind with lookfor,
67 -- disregarding any namespaces in OccName and extra attributes in Name and
69 Maybe.fromJust . find (\b -> case b of
71 NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
74 -- Accepts a port name and an argument to map to it.
75 -- Returns the appropriate line for in the port map
76 getPortMapEntry binds portname (Var id) =
77 "\t" ++ portname ++ " => " ++ signalname ++ "\n"
79 Port signalname = Maybe.fromMaybe
80 (error $ "Argument " ++ getOccString id ++ "is unknown")
83 getPortMapEntry binds _ a = error $ "Unsupported argument: " ++ (showSDoc $ ppr a)
86 PortNameMap -- The arguments that need to be applied to the
87 -- expression. Should always be the Args
89 -> PortNameMap -- The output ports that the expression should generate.
90 -> [(CoreBndr, PortNameMap)] -- A list of bindings in effect
91 -> CoreSyn.CoreExpr -- The expression to generate an architecture for
92 -> String -- The resulting VHDL code
94 -- A lambda expression binds the first argument (a) to the binder b.
95 getInstantiations (Args (a:as)) outs binds (Lam b expr) =
96 getInstantiations (Args as) outs ((b, a):binds) expr
98 -- A case expression that checks a single variable and has a single
99 -- alternative, can be used to take tuples apart
100 getInstantiations args outs binds (Case (Var v) b _ [res]) =
103 if (DataCon.isTupleCon datacon) then
104 getInstantiations args outs binds' expr
106 error "Data constructors other than tuples not supported"
108 error "Case binders other than tuples not supported"
110 binds' = (zip bind_vars tuple_ports) ++ binds
111 (altcon, bind_vars, expr) = res
112 -- Find the portnamemaps for each of the tuple's elements
113 Tuple tuple_ports = Maybe.fromMaybe
114 (error $ "Case expression uses unknown scrutinee " ++ getOccString v)
117 -- An application is an instantiation of a component
118 getInstantiations args outs binds app@(App expr arg) =
119 if isTupleConstructor f then
121 Tuple outports = outs
122 (tys, vals) = splitTupleConstructorArgs fargs
125 (\outs' expr' -> getInstantiations args outs' binds expr')
128 --indent ++ "F:\n" ++ (getInstantiations (' ':indent) expr) ++ "\n" ++ indent ++ "A:\n" ++ (getInstantiations (' ':indent) arg) ++ "\n"
129 "app : " ++ (getOccString f) ++ "\n"
131 -- Map input ports of f
132 ++ concat (zipWith (getPortMapEntry binds) ["portin0", "portin1"] fargs)
133 -- Map output ports of f
134 ++ mapOutputPorts (Port "portout") outs
137 ((Var f), fargs) = collectArgs app
139 getInstantiations args outs binds expr =
140 error $ "Unsupported expression" ++ (showSDoc $ ppr $ expr)
142 -- Is the given name a (binary) tuple constructor
143 isTupleConstructor :: Var.Var -> Bool
144 isTupleConstructor var =
145 Name.isWiredInName name
146 && Name.nameModule name == tuple_mod
147 && (Name.occNameString $ Name.nameOccName name) == "(,)"
149 name = Var.varName var
150 mod = nameModule name
151 tuple_mod = Module.mkModule (Module.stringToPackageId "ghc-prim") (Module.mkModuleName "GHC.Tuple")
153 -- Split arguments into type arguments and value arguments This is probably
154 -- not really sufficient (not sure if Types can actually occur as value
156 splitTupleConstructorArgs :: [CoreExpr] -> ([CoreExpr], [CoreExpr])
157 splitTupleConstructorArgs (e:es) =
159 Type t -> (e:tys, vals)
160 otherwise -> (tys, e:vals)
162 (tys, vals) = splitTupleConstructorArgs es
164 -- Map the output port of a component to the output port of the containing
166 mapOutputPorts (Port port) (Port signal) =
167 "\t" ++ port ++ " => " ++ signal ++ "\n"
169 -- Map matching output ports in the tuple
170 mapOutputPorts (Tuple ports) (Tuple signals) =
171 concat (zipWith mapOutputPorts ports signals)
173 getArchitecture (NonRec var expr) =
174 "architecture structural of " ++ name ++ " is\n"
176 ++ getInstantiations (Args inportnames) outport [] expr
177 ++ "end structural\n"
179 name = (getOccString var)
180 ty = CoreUtils.exprType expr
181 (fargs, res) = Type.splitFunTys ty
182 --state = if length fargs == 1 then () else (last fargs)
183 ports = if length fargs == 1 then fargs else (init fargs)
184 inportnames = case ports of
185 [port] -> [getPortNameMapForTy "portin" port]
186 ps -> getPortNameMapForTys "portin" 0 ps
187 outport = getPortNameMapForTy "portout" res
190 Args [PortNameMap] -- Each of the submaps represent an argument to the
191 -- function. Should only occur at top level.
192 | Tuple [PortNameMap]
195 -- Generate a port name map (or multiple for tuple types) in the given direction for
197 getPortNameMapForTys :: String -> Int -> [Type] -> [PortNameMap]
198 getPortNameMapForTys prefix num [] = []
199 getPortNameMapForTys prefix num (t:ts) =
200 (getPortNameMapForTy (prefix ++ show num) t) : getPortNameMapForTys prefix (num + 1) ts
202 getPortNameMapForTy :: String -> Type -> PortNameMap
203 getPortNameMapForTy name ty =
204 if (TyCon.isTupleTyCon tycon) then
205 -- Expand tuples we find
206 Tuple (getPortNameMapForTys name 0 args)
207 else -- Assume it's a type constructor application, ie simple data type
211 (tycon, args) = Type.splitTyConApp ty