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