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   -- Add the function to the session
 168   addFunc hsfunc
 169   -- Flatten the function
 170   let flatfunc = flattenFunction hsfunc bind
 171   -- Propagate state variables
 172   let flatfunc' = propagateState hsfunc flatfunc
 173   -- Store the flat function in the session
 174   setFlatFunc hsfunc flatfunc'
 175   -- Flatten any functions used
 176   let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc')
 177   State.mapM resolvFunc used_hsfuncs
 178   return ()
 179
 180 -- | Decide which incoming state variables will become state in the
 181 --   given function, and which will be propagate to other applied
 182 --   functions.
 183 propagateState ::
 184   HsFunction
 185   -> FlatFunction
 186   -> FlatFunction
 187
 188 propagateState hsfunc flatfunc =
 189     flatfunc {flat_defs = apps'}
 190   where
 191     apps = filter is_FApp (flat_defs flatfunc)
 192     apps' = map (propagateState' ()) apps
 193
 194 -- | Propagate the state into a single function application.
 195 propagateState' ::
 196   ()
 197   -> SigDef           -- ^ The function application to process. Must be
 198                       --   a FApp constructor.
 199   -> SigDef           -- ^ The resulting application.
 200
 201 propagateState' _ d = d
 202
 203 -- | Find the given function, flatten it and add it to the session. Then
 204 --   (recursively) do the same for any functions used.
 205 resolvFunc ::
 206   HsFunction        -- | The function to look for
 207   -> VHDLState ()
 208
 209 resolvFunc hsfunc = do
 210   -- See if the function is already known
 211   func <- getFunc hsfunc
 212   case func of
 213     -- Already known, do nothing
 214     Just _ -> do
 215       return ()
 216     -- New function, resolve it
 217     Nothing -> do
 218       -- Get the current module
 219       core <- getModule
 220       -- Find the named function
 221       let bind = findBind (cm_binds core) name
 222       case bind of
 223         Nothing -> error $ "Couldn't find function " ++ name ++ " in current module."
 224         Just b  -> flattenBind hsfunc b
 225   where
 226     name = hsFuncName hsfunc
 227
 228 -- | Translate a top level function declaration to a HsFunction. i.e., which
 229 --   interface will be provided by this function. This function essentially
 230 --   defines the "calling convention" for hardware models.
 231 mkHsFunction ::
 232   Var.Var         -- ^ The function defined
 233   -> Type         -- ^ The function type (including arguments!)
 234   -> Bool         -- ^ Is this a stateful function?
 235   -> HsFunction   -- ^ The resulting HsFunction
 236
 237 mkHsFunction f ty stateful=
 238   HsFunction hsname hsargs hsres
 239   where
 240     hsname  = getOccString f
 241     (arg_tys, res_ty) = Type.splitFunTys ty
 242     (hsargs, hsres) =
 243       if stateful
 244       then
 245         let
 246           -- The last argument must be state
 247           state_ty = last arg_tys
 248           state    = useAsState (mkHsValueMap state_ty)
 249           -- All but the last argument are inports
 250           inports = map (useAsPort . mkHsValueMap)(init arg_tys)
 251           hsargs   = inports ++ [state]
 252           hsres    = case splitTupleType res_ty of
 253             -- Result type must be a two tuple (state, ports)
 254             Just [outstate_ty, outport_ty] -> if Type.coreEqType state_ty outstate_ty
 255               then
 256                 Tuple [state, useAsPort (mkHsValueMap outport_ty)]
 257               else
 258                 error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty)
 259             otherwise                -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports."
 260         in
 261           (hsargs, hsres)
 262       else
 263         -- Just use everything as a port
 264         (map (useAsPort . mkHsValueMap) arg_tys, useAsPort $ mkHsValueMap res_ty)
 265
 266 -- | Adds signal names to the given FlatFunction
 267 nameFlatFunction ::
 268   HsFunction
 269   -> FuncData
 270   -> VHDLState ()
 271
 272 nameFlatFunction hsfunc fdata =
 273   let func = flatFunc fdata in
 274   case func of
 275     -- Skip (builtin) functions without a FlatFunction
 276     Nothing -> do return ()
 277     -- Name the signals in all other functions
 278     Just flatfunc ->
 279       let s = flat_sigs flatfunc in
 280       let s' = map nameSignal s in
 281       let flatfunc' = flatfunc { flat_sigs = s' } in
 282       setFlatFunc hsfunc flatfunc'
 283   where
 284     nameSignal :: (SignalId, SignalInfo) -> (SignalId, SignalInfo)
 285     nameSignal (id, info) =
 286       let hints = nameHints info in
 287       let parts = ("sig" : hints) ++ [show id] in
 288       let name = concat $ List.intersperse "_" parts in
 289       (id, info {sigName = Just name})
 290
 291 -- | Splits a tuple type into a list of element types, or Nothing if the type
 292 --   is not a tuple type.
 293 splitTupleType ::
 294   Type              -- ^ The type to split
 295   -> Maybe [Type]   -- ^ The tuples element types
 296
 297 splitTupleType ty =
 298   case Type.splitTyConApp_maybe ty of
 299     Just (tycon, args) -> if TyCon.isTupleTyCon tycon
 300       then
 301         Just args
 302       else
 303         Nothing
 304     Nothing -> Nothing
 305
 306 -- | A consise representation of a (set of) ports on a builtin function
 307 type PortMap = HsValueMap (String, AST.TypeMark)
 308 -- | A consise representation of a builtin function
 309 data BuiltIn = BuiltIn String [PortMap] PortMap
 310
 311 -- | Map a port specification of a builtin function to a VHDL Signal to put in
 312 --   a VHDLSignalMap
 313 toVHDLSignalMap :: HsValueMap (String, AST.TypeMark) -> VHDLSignalMap
 314 toVHDLSignalMap = fmap (\(name, ty) -> Just (VHDL.mkVHDLId name, ty))
 315
 316 -- | Translate a concise representation of a builtin function to something
 317 --   that can be put into FuncMap directly.
 318 addBuiltIn :: BuiltIn -> VHDLState ()
 319 addBuiltIn (BuiltIn name args res) = do
 320     addFunc hsfunc
 321     setEntity hsfunc entity
 322   where
 323     hsfunc = HsFunction name (map useAsPort args) (useAsPort res)
 324     entity = Entity (VHDL.mkVHDLId name) (map toVHDLSignalMap args) (toVHDLSignalMap res) Nothing
 325
 326 builtin_funcs =
 327   [
 328     BuiltIn "hwxor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
 329     BuiltIn "hwand" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
 330     BuiltIn "hwor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
 331     BuiltIn "hwnot" [(Single ("a", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty))
 332   ]
 333
 334 -- vim: set ts=8 sw=2 sts=2 expandtab: