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 -> [(CoreBndr, PortNameMap)] -- A list of bindings in effect
128 -> CoreSyn.CoreExpr -- The expression to generate an architecture for
129 -> String -- The resulting VHDL code
131 -- A lambda expression binds the first argument (a) to the binder b.
132 getInstantiations (Args (a:as)) binds (Lam b expr) =
133 getInstantiations (Args as) ((b, a):binds) expr
135 -- A case expression that checks a single variable and has a single
136 -- alternative, can be used to take tuples apart
137 getInstantiations args binds (Case (Var v) b _ [res]) =
140 if (DataCon.isTupleCon datacon) then
141 getInstantiations args binds' expr
143 error "Data constructors other than tuples not supported"
145 error "Case binders other than tuples not supported"
147 binds' = (zip bind_vars tuple_ports) ++ binds
148 (altcon, bind_vars, expr) = res
149 -- Find the portnamemaps for each of the tuple's elements
150 Tuple tuple_ports = Maybe.fromMaybe
151 (error $ "Case expression uses unknown scrutinee " ++ getOccString v)
154 -- An application is an instantiation of a component
155 getInstantiations args binds app@(App expr arg) =
156 --indent ++ "F:\n" ++ (getInstantiations (' ':indent) expr) ++ "\n" ++ indent ++ "A:\n" ++ (getInstantiations (' ':indent) arg) ++ "\n"
157 "app : " ++ (getOccString f) ++ "\n"
159 ++ concat (zipWith (getPortMapEntry binds) ["portin0", "portin1"] args)
162 ((Var f), args) = collectArgs app
164 getInstantiations args binds expr = showSDoc $ ppr $ expr
166 getArchitecture (NonRec var expr) =
167 "architecture structural of " ++ name ++ " is\n"
169 ++ getInstantiations (Args inportnames) [] expr
170 ++ "end structural\n"
172 name = (getOccString var)
173 ty = CoreUtils.exprType expr
174 (fargs, res) = Type.splitFunTys ty
175 --state = if length fargs == 1 then () else (last fargs)
176 ports = if length fargs == 1 then fargs else (init fargs)
177 inportnames = case ports of
178 [port] -> [getPortNameMapForTy "portin" port]
179 ps -> getPortNameMapForTys "portin" 0 ps
182 Args [PortNameMap] -- Each of the submaps represent an argument to the
183 -- function. Should only occur at top level.
184 | Tuple [PortNameMap]
187 -- Generate a port name map (or multiple for tuple types) in the given direction for
189 getPortNameMapForTys :: String -> Int -> [Type] -> [PortNameMap]
190 getPortNameMapForTys prefix num [] = []
191 getPortNameMapForTys prefix num (t:ts) =
192 (getPortNameMapForTy (prefix ++ show num) t) : getPortNameMapForTys prefix (num + 1) ts
194 getPortNameMapForTy :: String -> Type -> PortNameMap
195 getPortNameMapForTy name ty =
196 if (TyCon.isTupleTyCon tycon) then
197 -- Expand tuples we find
198 Tuple (getPortNameMapForTys name 0 args)
199 else -- Assume it's a type constructor application, ie simple data type
203 (tycon, args) = Type.splitTyConApp ty