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