Translator.hs

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