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