Translator.hs

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