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