1 module Main(main) where
4 import qualified CoreUtils
8 import qualified DataCon
12 import NameEnv ( lookupNameEnv )
13 import HscTypes ( cm_binds, cm_types )
14 import MonadUtils ( liftIO )
15 import Outputable ( showSDoc, ppr )
16 import GHC.Paths ( libdir )
17 import DynFlags ( defaultDynFlags )
22 defaultErrorHandler defaultDynFlags $ do
23 runGhc (Just libdir) $ do
24 dflags <- getSessionDynFlags
25 setSessionDynFlags dflags
26 --target <- guessTarget "adder.hs" Nothing
27 --liftIO (print (showSDoc (ppr (target))))
28 --liftIO $ printTarget target
31 --core <- GHC.compileToCoreSimplified "Adders.hs"
32 core <- GHC.compileToCoreSimplified "Adders.hs"
33 liftIO $ printBinds (cm_binds core)
34 let bind = findBind "no_carry_adder" (cm_binds core)
35 let NonRec var expr = bind
36 liftIO $ putStr $ showSDoc $ ppr expr
37 liftIO $ putStr "\n\n"
38 liftIO $ putStr $ getEntity bind
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 -- Generate a port (or multiple for tuple types) in the given direction for
76 getPortsForTys :: String -> String -> Int -> [Type] -> String
77 getPortsForTys dir prefix num [] = ""
78 getPortsForTys dir prefix num (t:ts) =
79 (getPortsForTy dir (prefix ++ show num) t) ++ getPortsForTys dir prefix (num + 1) ts
82 -- All of a function's arguments become IN ports, the result becomes on
83 -- (or more) OUT ports.
85 drop 2 (getPortsForTys "in" "portin" 0 args) ++ (getPortsForTy "out" "portout" res) ++ "\n"
87 (args, res) = Type.splitFunTys ty
89 getPortsForTy :: String -> String -> Type -> String
90 getPortsForTy dir name ty =
91 if (TyCon.isTupleTyCon tycon) then
92 -- Expand tuples we find
93 getPortsForTys dir name 0 args
94 else -- Assume it's a type constructor application, ie simple data type
96 vhdlTy = showSDoc $ ppr $ TyCon.tyConName tycon;
98 ";\n\t" ++ name ++ " : " ++ dir ++ " " ++ vhdlTy
100 (tycon, args) = Type.splitTyConApp ty
102 getEntity (NonRec var expr) =
103 "entity " ++ name ++ " is\n"
105 ++ getPortsForFunTy ty
107 ++ "end " ++ name ++ ";\n\n"
109 name = (getOccString var)
110 ty = CoreUtils.exprType expr
112 -- Accepts a port name and an argument to map to it.
113 -- Returns the appropriate line for in the port map
114 getPortMapEntry binds portname (Var id) =
115 "\t" ++ portname ++ " => " ++ signalname ++ "\n"
117 Port signalname = Maybe.fromMaybe
118 (error $ "Argument " ++ getOccString id ++ "is unknown")
121 getPortMapEntry binds _ a = error $ "Unsupported argument: " ++ (showSDoc $ ppr a)
124 PortNameMap -- The arguments that need to be applied to the
125 -- expression. Should always be the Args
127 -> PortNameMap -- The output ports that the expression should generate.
128 -> [(CoreBndr, PortNameMap)] -- A list of bindings in effect
129 -> CoreSyn.CoreExpr -- The expression to generate an architecture for
130 -> String -- The resulting VHDL code
132 -- A lambda expression binds the first argument (a) to the binder b.
133 getInstantiations (Args (a:as)) outs binds (Lam b expr) =
134 getInstantiations (Args as) outs ((b, a):binds) expr
136 -- A case expression that checks a single variable and has a single
137 -- alternative, can be used to take tuples apart
138 getInstantiations args outs binds (Case (Var v) b _ [res]) =
141 if (DataCon.isTupleCon datacon) then
142 getInstantiations args outs binds' expr
144 error "Data constructors other than tuples not supported"
146 error "Case binders other than tuples not supported"
148 binds' = (zip bind_vars tuple_ports) ++ binds
149 (altcon, bind_vars, expr) = res
150 -- Find the portnamemaps for each of the tuple's elements
151 Tuple tuple_ports = Maybe.fromMaybe
152 (error $ "Case expression uses unknown scrutinee " ++ getOccString v)
155 -- An application is an instantiation of a component
156 getInstantiations args outs binds app@(App expr arg) =
157 --indent ++ "F:\n" ++ (getInstantiations (' ':indent) expr) ++ "\n" ++ indent ++ "A:\n" ++ (getInstantiations (' ':indent) arg) ++ "\n"
158 "app : " ++ (getOccString f) ++ "\n"
160 -- Map input ports of f
161 ++ concat (zipWith (getPortMapEntry binds) ["portin0", "portin1"] args)
162 -- Map output ports of f
163 ++ mapOutputPorts (Port "portout") outs
166 ((Var f), args) = collectArgs app
168 getInstantiations args outs binds expr = showSDoc $ ppr $ expr
170 -- Map the output port of a component to the output port of the containing
172 mapOutputPorts (Port port) (Port signal) =
173 "\t" ++ port ++ " => " ++ signal ++ "\n"
175 -- Map matching output ports in the tuple
176 mapOutputPorts (Tuple ports) (Tuple signals) =
177 concat (zipWith mapOutputPorts ports signals)
179 getArchitecture (NonRec var expr) =
180 "architecture structural of " ++ name ++ " is\n"
182 ++ getInstantiations (Args inportnames) outport [] expr
183 ++ "end structural\n"
185 name = (getOccString var)
186 ty = CoreUtils.exprType expr
187 (fargs, res) = Type.splitFunTys ty
188 --state = if length fargs == 1 then () else (last fargs)
189 ports = if length fargs == 1 then fargs else (init fargs)
190 inportnames = case ports of
191 [port] -> [getPortNameMapForTy "portin" port]
192 ps -> getPortNameMapForTys "portin" 0 ps
193 outport = getPortNameMapForTy "portout" res
196 Args [PortNameMap] -- Each of the submaps represent an argument to the
197 -- function. Should only occur at top level.
198 | Tuple [PortNameMap]
201 -- Generate a port name map (or multiple for tuple types) in the given direction for
203 getPortNameMapForTys :: String -> Int -> [Type] -> [PortNameMap]
204 getPortNameMapForTys prefix num [] = []
205 getPortNameMapForTys prefix num (t:ts) =
206 (getPortNameMapForTy (prefix ++ show num) t) : getPortNameMapForTys prefix (num + 1) ts
208 getPortNameMapForTy :: String -> Type -> PortNameMap
209 getPortNameMapForTy name ty =
210 if (TyCon.isTupleTyCon tycon) then
211 -- Expand tuples we find
212 Tuple (getPortNameMapForTys name 0 args)
213 else -- Assume it's a type constructor application, ie simple data type
217 (tycon, args) = Type.splitTyConApp ty