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