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 qualified Data.Map as Map
  14 import Data.Generics
  15 import NameEnv ( lookupNameEnv )
  16 import HscTypes ( cm_binds, cm_types )
  17 import MonadUtils ( liftIO )
  18 import Outputable ( showSDoc, ppr )
  19 import GHC.Paths ( libdir )
  20 import DynFlags ( defaultDynFlags )
  21 import List ( find )
  22 import qualified List
  23 import qualified Monad
  24
  25 -- The following modules come from the ForSyDe project. They are really
  26 -- internal modules, so ForSyDe.cabal has to be modified prior to installing
  27 -- ForSyDe to get access to these modules.
  28 import qualified ForSyDe.Backend.VHDL.AST as AST
  29 import qualified ForSyDe.Backend.VHDL.Ppr
  30 import qualified ForSyDe.Backend.VHDL.FileIO
  31 import qualified ForSyDe.Backend.Ppr
  32 -- This is needed for rendering the pretty printed VHDL
  33 import Text.PrettyPrint.HughesPJ (render)
  34
  35 import TranslatorTypes
  36 import HsValueMap
  37 import Pretty
  38 import Flatten
  39 import FlattenTypes
  40 import VHDLTypes
  41 import qualified VHDL
  42
  43 main =
  44     do
  45       defaultErrorHandler defaultDynFlags $ do
  46         runGhc (Just libdir) $ do
  47           dflags <- getSessionDynFlags
  48           setSessionDynFlags dflags
  49           --target <- guessTarget "adder.hs" Nothing
  50           --liftIO (print (showSDoc (ppr (target))))
  51           --liftIO $ printTarget target
  52           --setTargets [target]
  53           --load LoadAllTargets
  54           --core <- GHC.compileToCoreSimplified "Adders.hs"
  55           core <- GHC.compileToCoreSimplified "Adders.hs"
  56           --liftIO $ printBinds (cm_binds core)
  57           let binds = Maybe.mapMaybe (findBind (cm_binds core)) ["dff"]
  58           liftIO $ putStr $ prettyShow binds
  59           -- Turn bind into VHDL
  60           let (vhdl, sess) = State.runState (mkVHDL binds) (VHDLSession core 0 Map.empty)
  61           liftIO $ putStr $ render $ ForSyDe.Backend.Ppr.ppr vhdl
  62           liftIO $ ForSyDe.Backend.VHDL.FileIO.writeDesignFile vhdl "../vhdl/vhdl/output.vhdl"
  63           liftIO $ putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
  64           return ()
  65   where
  66     -- Turns the given bind into VHDL
  67     mkVHDL binds = do
  68       -- Add the builtin functions
  69       mapM addBuiltIn builtin_funcs
  70       -- Create entities and architectures for them
  71       mapM processBind binds
  72       modFuncs nameFlatFunction
  73       modFuncs VHDL.createEntity
  74       modFuncs VHDL.createArchitecture
  75       VHDL.getDesignFile
  76
  77 findBind :: [CoreBind] -> String -> Maybe CoreBind
  78 findBind binds lookfor =
  79   -- This ignores Recs and compares the name of the bind with lookfor,
  80   -- disregarding any namespaces in OccName and extra attributes in Name and
  81   -- Var.
  82   find (\b -> case b of
  83     Rec l -> False
  84     NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
  85   ) binds
  86
  87 -- | Processes the given bind as a top level bind.
  88 processBind ::
  89   CoreBind                        -- The bind to process
  90   -> VHDLState ()
  91
  92 processBind  (Rec _) = error "Recursive binders not supported"
  93 processBind bind@(NonRec var expr) = do
  94   -- Create the function signature
  95   let ty = CoreUtils.exprType expr
  96   let hsfunc = mkHsFunction var ty
  97   flattenBind hsfunc bind
  98
  99 -- | Flattens the given bind into the given signature and adds it to the
 100 --   session. Then (recursively) finds any functions it uses and does the same
 101 --   with them.
 102 flattenBind ::
 103   HsFunction                         -- The signature to flatten into
 104   -> CoreBind                        -- The bind to flatten
 105   -> VHDLState ()
 106
 107 flattenBind _ (Rec _) = error "Recursive binders not supported"
 108
 109 flattenBind hsfunc bind@(NonRec var expr) = do
 110   -- Flatten the function
 111   let flatfunc = flattenFunction hsfunc bind
 112   addFunc hsfunc
 113   setFlatFunc hsfunc flatfunc
 114   let used_hsfuncs = map appFunc (flat_apps flatfunc)
 115   State.mapM resolvFunc used_hsfuncs
 116   return ()
 117
 118 -- | Find the given function, flatten it and add it to the session. Then
 119 --   (recursively) do the same for any functions used.
 120 resolvFunc ::
 121   HsFunction        -- | The function to look for
 122   -> VHDLState ()
 123
 124 resolvFunc hsfunc = do
 125   -- See if the function is already known
 126   func <- getFunc hsfunc
 127   case func of
 128     -- Already known, do nothing
 129     Just _ -> do
 130       return ()
 131     -- New function, resolve it
 132     Nothing -> do
 133       -- Get the current module
 134       core <- getModule
 135       -- Find the named function
 136       let bind = findBind (cm_binds core) name
 137       case bind of
 138         Nothing -> error $ "Couldn't find function " ++ name ++ " in current module."
 139         Just b  -> flattenBind hsfunc b
 140   where
 141     name = hsFuncName hsfunc
 142
 143 -- | Translate a top level function declaration to a HsFunction. i.e., which
 144 --   interface will be provided by this function. This function essentially
 145 --   defines the "calling convention" for hardware models.
 146 mkHsFunction ::
 147   Var.Var         -- ^ The function defined
 148   -> Type         -- ^ The function type (including arguments!)
 149   -> HsFunction   -- ^ The resulting HsFunction
 150
 151 mkHsFunction f ty =
 152   HsFunction hsname hsargs hsres
 153   where
 154     hsname  = getOccString f
 155     (arg_tys, res_ty) = Type.splitFunTys ty
 156     -- The last argument must be state
 157     state_ty = last arg_tys
 158     state    = useAsState (mkHsValueMap state_ty)
 159     -- All but the last argument are inports
 160     inports = map (useAsPort . mkHsValueMap)(init arg_tys)
 161     hsargs   = inports ++ [state]
 162     hsres    = case splitTupleType res_ty of
 163       -- Result type must be a two tuple (state, ports)
 164       Just [outstate_ty, outport_ty] -> if Type.coreEqType state_ty outstate_ty
 165         then
 166           Tuple [state, useAsPort (mkHsValueMap outport_ty)]
 167         else
 168           error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty)
 169       otherwise                -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports."
 170
 171 -- | Adds signal names to the given FlatFunction
 172 nameFlatFunction ::
 173   HsFunction
 174   -> FuncData
 175   -> VHDLState ()
 176
 177 nameFlatFunction hsfunc fdata =
 178   let func = flatFunc fdata in
 179   case func of
 180     -- Skip (builtin) functions without a FlatFunction
 181     Nothing -> do return ()
 182     -- Name the signals in all other functions
 183     Just flatfunc ->
 184       let s = flat_sigs flatfunc in
 185       let s' = map (\(id, (SignalInfo Nothing use ty)) -> (id, SignalInfo (Just $ "sig_" ++ (show id)) use ty)) s in
 186       let flatfunc' = flatfunc { flat_sigs = s' } in
 187       setFlatFunc hsfunc flatfunc'
 188
 189 -- | Splits a tuple type into a list of element types, or Nothing if the type
 190 --   is not a tuple type.
 191 splitTupleType ::
 192   Type              -- ^ The type to split
 193   -> Maybe [Type]   -- ^ The tuples element types
 194
 195 splitTupleType ty =
 196   case Type.splitTyConApp_maybe ty of
 197     Just (tycon, args) -> if TyCon.isTupleTyCon tycon
 198       then
 199         Just args
 200       else
 201         Nothing
 202     Nothing -> Nothing
 203
 204 -- | A consise representation of a (set of) ports on a builtin function
 205 type PortMap = HsValueMap (String, AST.TypeMark)
 206 -- | A consise representation of a builtin function
 207 data BuiltIn = BuiltIn String [PortMap] PortMap
 208
 209 -- | Map a port specification of a builtin function to a VHDL Signal to put in
 210 --   a VHDLSignalMap
 211 toVHDLSignalMap :: HsValueMap (String, AST.TypeMark) -> VHDLSignalMap
 212 toVHDLSignalMap = fmap (\(name, ty) -> Just (VHDL.mkVHDLId name, ty))
 213
 214 -- | Translate a concise representation of a builtin function to something
 215 --   that can be put into FuncMap directly.
 216 addBuiltIn :: BuiltIn -> VHDLState ()
 217 addBuiltIn (BuiltIn name args res) = do
 218     addFunc hsfunc
 219     setEntity hsfunc entity
 220   where
 221     hsfunc = HsFunction name (map useAsPort args) (useAsPort res)
 222     entity = Entity (VHDL.mkVHDLId name) (map toVHDLSignalMap args) (toVHDLSignalMap res) Nothing
 223
 224 builtin_funcs =
 225   [
 226     BuiltIn "hwxor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
 227     BuiltIn "hwand" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
 228     BuiltIn "hwor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
 229     BuiltIn "hwnot" [(Single ("a", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty))
 230   ]
 231
 232 -- vim: set ts=8 sw=2 sts=2 expandtab: