Translator.hs

   1 module Translator where
   2 import GHC
   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 HscTypes ( cm_binds, cm_types )
  17 import MonadUtils ( liftIO )
  18 import Outputable ( showSDoc, ppr )
  19 import GHC.Paths ( libdir )
  20 import DynFlags ( defaultDynFlags )
  21 import List ( find )
  22 import qualified List
  23 import qualified Monad
  24
  25 -- The following modules come from the ForSyDe project. They are really
  26 -- internal modules, so ForSyDe.cabal has to be modified prior to installing
  27 -- ForSyDe to get access to these modules.
  28 import qualified ForSyDe.Backend.VHDL.AST as AST
  29 import qualified ForSyDe.Backend.VHDL.Ppr
  30 import qualified ForSyDe.Backend.VHDL.FileIO
  31 import qualified ForSyDe.Backend.Ppr
  32 -- This is needed for rendering the pretty printed VHDL
  33 import Text.PrettyPrint.HughesPJ (render)
  34
  35 import TranslatorTypes
  36 import HsValueMap
  37 import Pretty
  38 import Flatten
  39 import FlattenTypes
  40 import VHDLTypes
  41 import qualified VHDL
  42
  43 main =
  44     do
  45       defaultErrorHandler defaultDynFlags $ do
  46         runGhc (Just libdir) $ do
  47           dflags <- getSessionDynFlags
  48           setSessionDynFlags dflags
  49           --target <- guessTarget "adder.hs" Nothing
  50           --liftIO (print (showSDoc (ppr (target))))
  51           --liftIO $ printTarget target
  52           --setTargets [target]
  53           --load LoadAllTargets
  54           --core <- GHC.compileToCoreSimplified "Adders.hs"
  55           core <- GHC.compileToCoreSimplified "Adders.hs"
  56           --liftIO $ printBinds (cm_binds core)
  57           let binds = Maybe.mapMaybe (findBind (cm_binds core)) ["sfull_adder"]
  58           liftIO $ putStr $ prettyShow binds
  59           -- Turn bind into VHDL
  60           let (vhdl, sess) = State.runState (mkVHDL binds) (VHDLSession core 0 Map.empty)
  61           liftIO $ putStr $ render $ ForSyDe.Backend.Ppr.ppr vhdl
  62           liftIO $ ForSyDe.Backend.VHDL.FileIO.writeDesignFile vhdl "../vhdl/vhdl/output.vhdl"
  63           liftIO $ putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
  64           return ()
  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       -- Extract the library units generated from all the functions in the
  76       -- session.
  77       funcs <- getFuncs
  78       let units = concat $ map VHDL.getLibraryUnits funcs
  79       return $ AST.DesignFile
  80         []
  81         units
  82
  83 findBind :: [CoreBind] -> String -> Maybe CoreBind
  84 findBind binds lookfor =
  85   -- This ignores Recs and compares the name of the bind with lookfor,
  86   -- disregarding any namespaces in OccName and extra attributes in Name and
  87   -- Var.
  88   find (\b -> case b of
  89     Rec l -> False
  90     NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
  91   ) binds
  92
  93 -- | Processes the given bind as a top level bind.
  94 processBind ::
  95   CoreBind                        -- The bind to process
  96   -> VHDLState ()
  97
  98 processBind  (Rec _) = error "Recursive binders not supported"
  99 processBind bind@(NonRec var expr) = do
 100   -- Create the function signature
 101   let ty = CoreUtils.exprType expr
 102   let hsfunc = mkHsFunction var ty
 103   flattenBind hsfunc bind
 104
 105 -- | Flattens the given bind into the given signature and adds it to the
 106 --   session. Then (recursively) finds any functions it uses and does the same
 107 --   with them.
 108 flattenBind ::
 109   HsFunction                         -- The signature to flatten into
 110   -> CoreBind                        -- The bind to flatten
 111   -> VHDLState ()
 112
 113 flattenBind _ (Rec _) = error "Recursive binders not supported"
 114
 115 flattenBind hsfunc bind@(NonRec var expr) = do
 116   -- Flatten the function
 117   let flatfunc = flattenFunction hsfunc bind
 118   addFunc hsfunc
 119   setFlatFunc hsfunc flatfunc
 120   let used_hsfuncs = map appFunc (flat_apps flatfunc)
 121   State.mapM resolvFunc used_hsfuncs
 122   return ()
 123
 124 -- | Find the given function, flatten it and add it to the session. Then
 125 --   (recursively) do the same for any functions used.
 126 resolvFunc ::
 127   HsFunction        -- | The function to look for
 128   -> VHDLState ()
 129
 130 resolvFunc hsfunc = do
 131   -- See if the function is already known
 132   func <- getFunc hsfunc
 133   case func of
 134     -- Already known, do nothing
 135     Just _ -> do
 136       return ()
 137     -- New function, resolve it
 138     Nothing -> do
 139       -- Get the current module
 140       core <- getModule
 141       -- Find the named function
 142       let bind = findBind (cm_binds core) name
 143       case bind of
 144         Nothing -> error $ "Couldn't find function " ++ name ++ " in current module."
 145         Just b  -> flattenBind hsfunc b
 146   where
 147     name = hsFuncName hsfunc
 148
 149 -- | Translate a top level function declaration to a HsFunction. i.e., which
 150 --   interface will be provided by this function. This function essentially
 151 --   defines the "calling convention" for hardware models.
 152 mkHsFunction ::
 153   Var.Var         -- ^ The function defined
 154   -> Type         -- ^ The function type (including arguments!)
 155   -> HsFunction   -- ^ The resulting HsFunction
 156
 157 mkHsFunction f ty =
 158   HsFunction hsname hsargs hsres
 159   where
 160     hsname  = getOccString f
 161     (arg_tys, res_ty) = Type.splitFunTys ty
 162     -- The last argument must be state
 163     state_ty = last arg_tys
 164     state    = useAsState (mkHsValueMap state_ty)
 165     -- All but the last argument are inports
 166     inports = map (useAsPort . mkHsValueMap)(init arg_tys)
 167     hsargs   = inports ++ [state]
 168     hsres    = case splitTupleType res_ty of
 169       -- Result type must be a two tuple (state, ports)
 170       Just [outstate_ty, outport_ty] -> if Type.coreEqType state_ty outstate_ty
 171         then
 172           Tuple [state, useAsPort (mkHsValueMap outport_ty)]
 173         else
 174           error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty)
 175       otherwise                -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports."
 176
 177 -- | Adds signal names to the given FlatFunction
 178 nameFlatFunction ::
 179   HsFunction
 180   -> FuncData
 181   -> VHDLState ()
 182
 183 nameFlatFunction hsfunc fdata =
 184   let func = flatFunc fdata in
 185   case func of
 186     -- Skip (builtin) functions without a FlatFunction
 187     Nothing -> do return ()
 188     -- Name the signals in all other functions
 189     Just flatfunc ->
 190       let s = flat_sigs flatfunc in
 191       let s' = map (\(id, (SignalInfo Nothing use ty)) -> (id, SignalInfo (Just $ "sig_" ++ (show id)) use ty)) s in
 192       let flatfunc' = flatfunc { flat_sigs = s' } in
 193       setFlatFunc hsfunc flatfunc'
 194
 195 -- | Splits a tuple type into a list of element types, or Nothing if the type
 196 --   is not a tuple type.
 197 splitTupleType ::
 198   Type              -- ^ The type to split
 199   -> Maybe [Type]   -- ^ The tuples element types
 200
 201 splitTupleType ty =
 202   case Type.splitTyConApp_maybe ty of
 203     Just (tycon, args) -> if TyCon.isTupleTyCon tycon
 204       then
 205         Just args
 206       else
 207         Nothing
 208     Nothing -> Nothing
 209
 210 -- | A consise representation of a (set of) ports on a builtin function
 211 type PortMap = HsValueMap (String, AST.TypeMark)
 212 -- | A consise representation of a builtin function
 213 data BuiltIn = BuiltIn String [PortMap] PortMap
 214
 215 -- | Map a port specification of a builtin function to a VHDL Signal to put in
 216 --   a VHDLSignalMap
 217 toVHDLSignalMap :: HsValueMap (String, AST.TypeMark) -> VHDLSignalMap
 218 toVHDLSignalMap = fmap (\(name, ty) -> (VHDL.mkVHDLId name, ty))
 219
 220 -- | Translate a concise representation of a builtin function to something
 221 --   that can be put into FuncMap directly.
 222 addBuiltIn :: BuiltIn -> VHDLState ()
 223 addBuiltIn (BuiltIn name args res) = do
 224     addFunc hsfunc
 225     setEntity hsfunc entity
 226   where
 227     hsfunc = HsFunction name (map useAsPort args) (useAsPort res)
 228     entity = Entity (VHDL.mkVHDLId name) (map toVHDLSignalMap args) (toVHDLSignalMap res) Nothing
 229
 230 builtin_funcs =
 231   [
 232     BuiltIn "hwxor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
 233     BuiltIn "hwand" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
 234     BuiltIn "hwor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
 235     BuiltIn "hwnot" [(Single ("a", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty))
 236   ]
 237
 238 -- vim: set ts=8 sw=2 sts=2 expandtab: