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 Data.Generics
  14 import NameEnv ( lookupNameEnv )
  15 import HscTypes ( cm_binds, cm_types )
  16 import MonadUtils ( liftIO )
  17 import Outputable ( showSDoc, ppr )
  18 import GHC.Paths ( libdir )
  19 import DynFlags ( defaultDynFlags )
  20 import List ( find )
  21 import qualified List
  22 import qualified Monad
  23
  24 -- The following modules come from the ForSyDe project. They are really
  25 -- internal modules, so ForSyDe.cabal has to be modified prior to installing
  26 -- ForSyDe to get access to these modules.
  27 import qualified ForSyDe.Backend.VHDL.AST as AST
  28 import qualified ForSyDe.Backend.VHDL.Ppr
  29 import qualified ForSyDe.Backend.VHDL.FileIO
  30 import qualified ForSyDe.Backend.Ppr
  31 -- This is needed for rendering the pretty printed VHDL
  32 import Text.PrettyPrint.HughesPJ (render)
  33
  34 import TranslatorTypes
  35 import Pretty
  36 import Flatten
  37 import qualified VHDL
  38
  39 main =
  40     do
  41       defaultErrorHandler defaultDynFlags $ do
  42         runGhc (Just libdir) $ do
  43           dflags <- getSessionDynFlags
  44           setSessionDynFlags dflags
  45           --target <- guessTarget "adder.hs" Nothing
  46           --liftIO (print (showSDoc (ppr (target))))
  47           --liftIO $ printTarget target
  48           --setTargets [target]
  49           --load LoadAllTargets
  50           --core <- GHC.compileToCoreSimplified "Adders.hs"
  51           core <- GHC.compileToCoreSimplified "Adders.hs"
  52           --liftIO $ printBinds (cm_binds core)
  53           let binds = Maybe.mapMaybe (findBind (cm_binds core)) ["sfull_adder"]
  54           liftIO $ printBinds binds
  55           -- Turn bind into VHDL
  56           let (vhdl, sess) = State.runState (mkVHDL binds) (VHDLSession 0 [])
  57           liftIO $ putStr $ render $ ForSyDe.Backend.Ppr.ppr vhdl
  58           liftIO $ ForSyDe.Backend.VHDL.FileIO.writeDesignFile vhdl "../vhdl/vhdl/output.vhdl"
  59           liftIO $ putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
  60           return ()
  61   where
  62     -- Turns the given bind into VHDL
  63     mkVHDL binds = do
  64       -- Add the builtin functions
  65       --mapM (uncurry addFunc) builtin_funcs
  66       -- Create entities and architectures for them
  67       mapM flattenBind binds
  68       return $ AST.DesignFile
  69         []
  70         []
  71
  72 printTarget (Target (TargetFile file (Just x)) obj Nothing) =
  73   print $ show file
  74
  75 printBinds [] = putStr "done\n\n"
  76 printBinds (b:bs) = do
  77   printBind b
  78   putStr "\n"
  79   printBinds bs
  80
  81 printBind (NonRec b expr) = do
  82   putStr "NonRec: "
  83   printBind' (b, expr)
  84
  85 printBind (Rec binds) = do
  86   putStr "Rec: \n"
  87   foldl1 (>>) (map printBind' binds)
  88
  89 printBind' (b, expr) = do
  90   putStr $ getOccString b
  91   putStr $ showSDoc $ ppr expr
  92   putStr "\n"
  93
  94 findBind :: [CoreBind] -> String -> Maybe CoreBind
  95 findBind binds lookfor =
  96   -- This ignores Recs and compares the name of the bind with lookfor,
  97   -- disregarding any namespaces in OccName and extra attributes in Name and
  98   -- Var.
  99   find (\b -> case b of
 100     Rec l -> False
 101     NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
 102   ) binds
 103
 104 -- | Flattens the given bind and adds it to the session. Then (recursively)
 105 --   finds any functions it uses and does the same with them.
 106 flattenBind ::
 107   CoreBind                        -- The binder to flatten
 108   -> VHDLState ()
 109
 110 flattenBind (Rec _) = error "Recursive binders not supported"
 111
 112 flattenBind bind@(NonRec var expr) = do
 113   -- Create the function signature
 114   let ty = CoreUtils.exprType expr
 115   let hsfunc = mkHsFunction var ty
 116   --hwfunc <- mkHWFunction bind hsfunc
 117   -- Add it to the session
 118   --addFunc hsfunc hwfunc
 119   let flatfunc = flattenFunction hsfunc bind
 120   addFunc hsfunc flatfunc
 121   let used_hsfuncs = map appFunc (apps flatfunc)
 122   State.mapM resolvFunc used_hsfuncs
 123   return ()
 124
 125 -- | Find the given function, flatten it and add it to the session. Then
 126 --   (recursively) do the same for any functions used.
 127 resolvFunc ::
 128   HsFunction        -- | The function to look for
 129   -> VHDLState ()
 130
 131 resolvFunc hsfunc =
 132   return ()
 133
 134 -- | Translate a top level function declaration to a HsFunction. i.e., which
 135 --   interface will be provided by this function. This function essentially
 136 --   defines the "calling convention" for hardware models.
 137 mkHsFunction ::
 138   Var.Var         -- ^ The function defined
 139   -> Type         -- ^ The function type (including arguments!)
 140   -> HsFunction   -- ^ The resulting HsFunction
 141
 142 mkHsFunction f ty =
 143   HsFunction hsname hsargs hsres
 144   where
 145     hsname  = getOccString f
 146     (arg_tys, res_ty) = Type.splitFunTys ty
 147     -- The last argument must be state
 148     state_ty = last arg_tys
 149     state    = useAsState (mkHsValueMap state_ty)
 150     -- All but the last argument are inports
 151     inports = map (useAsPort . mkHsValueMap)(init arg_tys)
 152     hsargs   = inports ++ [state]
 153     hsres    = case splitTupleType res_ty of
 154       -- Result type must be a two tuple (state, ports)
 155       Just [outstate_ty, outport_ty] -> if Type.coreEqType state_ty outstate_ty
 156         then
 157           Tuple [state, useAsPort (mkHsValueMap outport_ty)]
 158         else
 159           error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty)
 160       otherwise                -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports."
 161
 162 -- | Splits a tuple type into a list of element types, or Nothing if the type
 163 --   is not a tuple type.
 164 splitTupleType ::
 165   Type              -- ^ The type to split
 166   -> Maybe [Type]   -- ^ The tuples element types
 167
 168 splitTupleType ty =
 169   case Type.splitTyConApp_maybe ty of
 170     Just (tycon, args) -> if TyCon.isTupleTyCon tycon
 171       then
 172         Just args
 173       else
 174         Nothing
 175     Nothing -> Nothing
 176
 177 -- vim: set ts=8 sw=2 sts=2 expandtab: