Translator.hs

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