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