defa8cabe7990b7dc8bc8bf2841a88884edeac99
[matthijs/master-project/cλash.git] / Translator.hs
1 module Translator where
2 import GHC
3 import CoreSyn
4 import qualified CoreUtils
5 import qualified Var
6 import qualified Type
7 import qualified TyCon
8 import qualified DataCon
9 import qualified Maybe
10 import qualified Module
11 import qualified Control.Monad.State as State
12 import Name
13 import Data.Generics
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 )
20 import List ( find )
21 import qualified List
22 import qualified Monad
23
24 -- The following modules come from the ForSyDe project. They are really
25 -- internal modules, so ForSyDe.cabal has to be modified prior to installing
26 -- ForSyDe to get access to these modules.
27 import qualified ForSyDe.Backend.VHDL.AST as AST
28 import qualified ForSyDe.Backend.VHDL.Ppr
29 import qualified ForSyDe.Backend.VHDL.FileIO
30 import qualified ForSyDe.Backend.Ppr
31 -- This is needed for rendering the pretty printed VHDL
32 import Text.PrettyPrint.HughesPJ (render)
33
34 import TranslatorTypes
35 import Pretty
36 import Flatten
37 import qualified VHDL
38
39 main = 
40     do
41       defaultErrorHandler defaultDynFlags $ do
42         runGhc (Just libdir) $ do
43           dflags <- getSessionDynFlags
44           setSessionDynFlags dflags
45           --target <- guessTarget "adder.hs" Nothing
46           --liftIO (print (showSDoc (ppr (target))))
47           --liftIO $ printTarget target
48           --setTargets [target]
49           --load LoadAllTargets
50           --core <- GHC.compileToCoreSimplified "Adders.hs"
51           core <- GHC.compileToCoreSimplified "Adders.hs"
52           --liftIO $ printBinds (cm_binds core)
53           let binds = Maybe.mapMaybe (findBind (cm_binds core)) ["sfull_adder"]
54           liftIO $ printBinds binds
55           -- Turn bind into VHDL
56           let (vhdl, sess) = State.runState (mkVHDL binds) (VHDLSession 0 [])
57           liftIO $ putStr $ render $ ForSyDe.Backend.Ppr.ppr vhdl
58           liftIO $ ForSyDe.Backend.VHDL.FileIO.writeDesignFile vhdl "../vhdl/vhdl/output.vhdl"
59           liftIO $ putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
60           return ()
61   where
62     -- Turns the given bind into VHDL
63     mkVHDL binds = do
64       -- Add the builtin functions
65       --mapM (uncurry addFunc) builtin_funcs
66       -- Create entities and architectures for them
67       mapM flattenBind binds
68       return $ AST.DesignFile 
69         []
70         []
71
72 printTarget (Target (TargetFile file (Just x)) obj Nothing) =
73   print $ show file
74
75 printBinds [] = putStr "done\n\n"
76 printBinds (b:bs) = do
77   printBind b
78   putStr "\n"
79   printBinds bs
80
81 printBind (NonRec b expr) = do
82   putStr "NonRec: "
83   printBind' (b, expr)
84
85 printBind (Rec binds) = do
86   putStr "Rec: \n"  
87   foldl1 (>>) (map printBind' binds)
88
89 printBind' (b, expr) = do
90   putStr $ getOccString b
91   putStr $ showSDoc $ ppr expr
92   putStr "\n"
93
94 findBind :: [CoreBind] -> String -> Maybe CoreBind
95 findBind binds lookfor =
96   -- This ignores Recs and compares the name of the bind with lookfor,
97   -- disregarding any namespaces in OccName and extra attributes in Name and
98   -- Var.
99   find (\b -> case b of 
100     Rec l -> False
101     NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
102   ) binds
103
104 -- | Flattens the given bind and adds it to the session. Then (recursively)
105 --   finds any functions it uses and does the same with them.
106 flattenBind ::
107   CoreBind                        -- The binder to flatten
108   -> VHDLState ()
109
110 flattenBind (Rec _) = error "Recursive binders not supported"
111
112 flattenBind bind@(NonRec var expr) = do
113   -- Create the function signature
114   let ty = CoreUtils.exprType expr
115   let hsfunc = mkHsFunction var ty
116   --hwfunc <- mkHWFunction bind hsfunc
117   -- Add it to the session
118   --addFunc hsfunc hwfunc 
119   let flatfunc = flattenFunction hsfunc bind
120   addFunc hsfunc flatfunc
121   let used_hsfuncs = map appFunc (apps flatfunc)
122   State.mapM resolvFunc used_hsfuncs
123   return ()
124
125 -- | Find the given function, flatten it and add it to the session. Then
126 --   (recursively) do the same for any functions used.
127 resolvFunc ::
128   HsFunction        -- | The function to look for
129   -> VHDLState ()
130
131 resolvFunc hsfunc =
132   return ()
133
134 -- | Translate a top level function declaration to a HsFunction. i.e., which
135 --   interface will be provided by this function. This function essentially
136 --   defines the "calling convention" for hardware models.
137 mkHsFunction ::
138   Var.Var         -- ^ The function defined
139   -> Type         -- ^ The function type (including arguments!)
140   -> HsFunction   -- ^ The resulting HsFunction
141
142 mkHsFunction f ty =
143   HsFunction hsname hsargs hsres
144   where
145     hsname  = getOccString f
146     (arg_tys, res_ty) = Type.splitFunTys ty
147     -- The last argument must be state
148     state_ty = last arg_tys
149     state    = useAsState (mkHsValueMap state_ty)
150     -- All but the last argument are inports
151     inports = map (useAsPort . mkHsValueMap)(init arg_tys)
152     hsargs   = inports ++ [state]
153     hsres    = case splitTupleType res_ty of
154       -- Result type must be a two tuple (state, ports)
155       Just [outstate_ty, outport_ty] -> if Type.coreEqType state_ty outstate_ty
156         then
157           Tuple [state, useAsPort (mkHsValueMap outport_ty)]
158         else
159           error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty)
160       otherwise                -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports."
161
162 -- | Splits a tuple type into a list of element types, or Nothing if the type
163 --   is not a tuple type.
164 splitTupleType ::
165   Type              -- ^ The type to split
166   -> Maybe [Type]   -- ^ The tuples element types
167
168 splitTupleType ty =
169   case Type.splitTyConApp_maybe ty of
170     Just (tycon, args) -> if TyCon.isTupleTyCon tycon 
171       then
172         Just args
173       else
174         Nothing
175     Nothing -> Nothing
176
177 -- vim: set ts=8 sw=2 sts=2 expandtab: