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