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 $ putStr $ prettyShow binds
  55           -- Turn bind into VHDL
  56           let (vhdl, sess) = State.runState (mkVHDL binds) (VHDLSession core 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 findBind :: [CoreBind] -> String -> Maybe CoreBind
  73 findBind binds lookfor =
  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
  76   -- Var.
  77   find (\b -> case b of
  78     Rec l -> False
  79     NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
  80   ) binds
  81
  82 -- | Flattens the given bind and adds it to the session. Then (recursively)
  83 --   finds any functions it uses and does the same with them.
  84 flattenBind ::
  85   CoreBind                        -- The binder to flatten
  86   -> VHDLState ()
  87
  88 flattenBind (Rec _) = error "Recursive binders not supported"
  89
  90 flattenBind bind@(NonRec var expr) = do
  91   -- Create the function signature
  92   let ty = CoreUtils.exprType expr
  93   let hsfunc = mkHsFunction var ty
  94   --hwfunc <- mkHWFunction bind hsfunc
  95   -- Add it to the session
  96   --addFunc hsfunc hwfunc
  97   let flatfunc = flattenFunction hsfunc bind
  98   addFunc hsfunc flatfunc
  99   let used_hsfuncs = map appFunc (apps flatfunc)
 100   State.mapM resolvFunc used_hsfuncs
 101   return ()
 102
 103 -- | Find the given function, flatten it and add it to the session. Then
 104 --   (recursively) do the same for any functions used.
 105 resolvFunc ::
 106   HsFunction        -- | The function to look for
 107   -> VHDLState ()
 108
 109 resolvFunc hsfunc = do
 110   -- See if the function is already known
 111   func <- getFunc hsfunc
 112   case func of
 113     -- Already known, do nothing
 114     Just _ -> do
 115       return ()
 116     -- New function, resolve it
 117     Nothing -> do
 118       -- Get the current module
 119       core <- getModule
 120       -- Find the named function
 121       let bind = findBind (cm_binds core) name
 122       case bind of
 123         Nothing -> error $ "Couldn't find function " ++ name ++ " in current module."
 124         Just b  -> flattenBind b
 125   where
 126     name = hsFuncName hsfunc
 127
 128 -- | Translate a top level function declaration to a HsFunction. i.e., which
 129 --   interface will be provided by this function. This function essentially
 130 --   defines the "calling convention" for hardware models.
 131 mkHsFunction ::
 132   Var.Var         -- ^ The function defined
 133   -> Type         -- ^ The function type (including arguments!)
 134   -> HsFunction   -- ^ The resulting HsFunction
 135
 136 mkHsFunction f ty =
 137   HsFunction hsname hsargs hsres
 138   where
 139     hsname  = getOccString f
 140     (arg_tys, res_ty) = Type.splitFunTys ty
 141     -- The last argument must be state
 142     state_ty = last arg_tys
 143     state    = useAsState (mkHsValueMap state_ty)
 144     -- All but the last argument are inports
 145     inports = map (useAsPort . mkHsValueMap)(init arg_tys)
 146     hsargs   = inports ++ [state]
 147     hsres    = case splitTupleType res_ty of
 148       -- Result type must be a two tuple (state, ports)
 149       Just [outstate_ty, outport_ty] -> if Type.coreEqType state_ty outstate_ty
 150         then
 151           Tuple [state, useAsPort (mkHsValueMap outport_ty)]
 152         else
 153           error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty)
 154       otherwise                -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports."
 155
 156 -- | Splits a tuple type into a list of element types, or Nothing if the type
 157 --   is not a tuple type.
 158 splitTupleType ::
 159   Type              -- ^ The type to split
 160   -> Maybe [Type]   -- ^ The tuples element types
 161
 162 splitTupleType ty =
 163   case Type.splitTyConApp_maybe ty of
 164     Just (tycon, args) -> if TyCon.isTupleTyCon tycon
 165       then
 166         Just args
 167       else
 168         Nothing
 169     Nothing -> Nothing
 170
 171 -- vim: set ts=8 sw=2 sts=2 expandtab: