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 =
 110   return ()
 111
 112 -- | Translate a top level function declaration to a HsFunction. i.e., which
 113 --   interface will be provided by this function. This function essentially
 114 --   defines the "calling convention" for hardware models.
 115 mkHsFunction ::
 116   Var.Var         -- ^ The function defined
 117   -> Type         -- ^ The function type (including arguments!)
 118   -> HsFunction   -- ^ The resulting HsFunction
 119
 120 mkHsFunction f ty =
 121   HsFunction hsname hsargs hsres
 122   where
 123     hsname  = getOccString f
 124     (arg_tys, res_ty) = Type.splitFunTys ty
 125     -- The last argument must be state
 126     state_ty = last arg_tys
 127     state    = useAsState (mkHsValueMap state_ty)
 128     -- All but the last argument are inports
 129     inports = map (useAsPort . mkHsValueMap)(init arg_tys)
 130     hsargs   = inports ++ [state]
 131     hsres    = case splitTupleType res_ty of
 132       -- Result type must be a two tuple (state, ports)
 133       Just [outstate_ty, outport_ty] -> if Type.coreEqType state_ty outstate_ty
 134         then
 135           Tuple [state, useAsPort (mkHsValueMap outport_ty)]
 136         else
 137           error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty)
 138       otherwise                -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports."
 139
 140 -- | Splits a tuple type into a list of element types, or Nothing if the type
 141 --   is not a tuple type.
 142 splitTupleType ::
 143   Type              -- ^ The type to split
 144   -> Maybe [Type]   -- ^ The tuples element types
 145
 146 splitTupleType ty =
 147   case Type.splitTyConApp_maybe ty of
 148     Just (tycon, args) -> if TyCon.isTupleTyCon tycon
 149       then
 150         Just args
 151       else
 152         Nothing
 153     Nothing -> Nothing
 154
 155 -- vim: set ts=8 sw=2 sts=2 expandtab: