Translator.hs

   1 module Translator where
   2 import qualified Directory
   3 import qualified List
   4 import Debug.Trace
   5 import qualified Control.Arrow as Arrow
   6 import GHC hiding (loadModule, sigName)
   7 import CoreSyn
   8 import qualified CoreUtils
   9 import qualified Var
  10 import qualified Type
  11 import qualified TyCon
  12 import qualified DataCon
  13 import qualified HscMain
  14 import qualified SrcLoc
  15 import qualified FastString
  16 import qualified Maybe
  17 import qualified Module
  18 import qualified Data.Foldable as Foldable
  19 import qualified Control.Monad.Trans.State as State
  20 import Name
  21 import qualified Data.Map as Map
  22 import Data.Accessor
  23 import Data.Generics
  24 import NameEnv ( lookupNameEnv )
  25 import qualified HscTypes
  26 import HscTypes ( cm_binds, cm_types )
  27 import MonadUtils ( liftIO )
  28 import Outputable ( showSDoc, ppr )
  29 import GHC.Paths ( libdir )
  30 import DynFlags ( defaultDynFlags )
  31 import qualified UniqSupply
  32 import List ( find )
  33 import qualified List
  34 import qualified Monad
  35
  36 -- The following modules come from the ForSyDe project. They are really
  37 -- internal modules, so ForSyDe.cabal has to be modified prior to installing
  38 -- ForSyDe to get access to these modules.
  39 import qualified ForSyDe.Backend.VHDL.AST as AST
  40 import qualified ForSyDe.Backend.VHDL.Ppr
  41 import qualified ForSyDe.Backend.VHDL.FileIO
  42 import qualified ForSyDe.Backend.Ppr
  43 -- This is needed for rendering the pretty printed VHDL
  44 import Text.PrettyPrint.HughesPJ (render)
  45
  46 import TranslatorTypes
  47 import HsValueMap
  48 import Pretty
  49 import Normalize
  50 import Flatten
  51 import FlattenTypes
  52 import VHDLTypes
  53 import qualified VHDL
  54
  55 makeVHDL :: String -> String -> Bool -> IO ()
  56 makeVHDL filename name stateful = do
  57   -- Load the module
  58   core <- loadModule filename
  59   -- Translate to VHDL
  60   vhdl <- moduleToVHDL core [(name, stateful)]
  61   -- Write VHDL to file
  62   let dir = "./vhdl/" ++ name ++ "/"
  63   mapM (writeVHDL dir) vhdl
  64   return ()
  65
  66 -- | Show the core structure of the given binds in the given file.
  67 listBind :: String -> String -> IO ()
  68 listBind filename name = do
  69   core <- loadModule filename
  70   let [(b, expr)] = findBinds core [name]
  71   putStr "\n"
  72   putStr $ prettyShow expr
  73   putStr "\n\n"
  74   putStr $ showSDoc $ ppr expr
  75   putStr "\n\n"
  76   putStr $ showSDoc $ ppr $ CoreUtils.exprType expr
  77   putStr "\n\n"
  78
  79 -- | Translate the binds with the given names from the given core module to
  80 --   VHDL. The Bool in the tuple makes the function stateful (True) or
  81 --   stateless (False).
  82 moduleToVHDL :: HscTypes.CoreModule -> [(String, Bool)] -> IO [(AST.VHDLId, AST.DesignFile)]
  83 moduleToVHDL core list = do
  84   let (names, statefuls) = unzip list
  85   let binds = map fst $ findBinds core names
  86   -- Generate a UniqSupply
  87   -- Running
  88   --    egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
  89   -- on the compiler dir of ghc suggests that 'z' is not used to generate a
  90   -- unique supply anywhere.
  91   uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
  92   -- Turn bind into VHDL
  93   let all_bindings = (CoreSyn.flattenBinds $ cm_binds core)
  94   let normalized_bindings = normalizeModule uniqSupply all_bindings binds statefuls
  95   let vhdl = VHDL.createDesignFiles normalized_bindings
  96   mapM (putStr . render . ForSyDe.Backend.Ppr.ppr . snd) vhdl
  97   --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
  98   return vhdl
  99   where
 100
 101 -- | Write the given design file to a file with the given name inside the
 102 --   given dir
 103 writeVHDL :: String -> (AST.VHDLId, AST.DesignFile) -> IO ()
 104 writeVHDL dir (name, vhdl) = do
 105   -- Create the dir if needed
 106   exists <- Directory.doesDirectoryExist dir
 107   Monad.unless exists $ Directory.createDirectory dir
 108   -- Find the filename
 109   let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl"
 110   -- Write the file
 111   ForSyDe.Backend.VHDL.FileIO.writeDesignFile vhdl fname
 112
 113 -- | Loads the given file and turns it into a core module.
 114 loadModule :: String -> IO HscTypes.CoreModule
 115 loadModule filename =
 116   defaultErrorHandler defaultDynFlags $ do
 117     runGhc (Just libdir) $ do
 118       dflags <- getSessionDynFlags
 119       setSessionDynFlags dflags
 120       --target <- guessTarget "adder.hs" Nothing
 121       --liftIO (print (showSDoc (ppr (target))))
 122       --liftIO $ printTarget target
 123       --setTargets [target]
 124       --load LoadAllTargets
 125       --core <- GHC.compileToCoreSimplified "Adders.hs"
 126       core <- GHC.compileToCoreModule filename
 127       return core
 128
 129 -- | Extracts the named binds from the given module.
 130 findBinds :: HscTypes.CoreModule -> [String] -> [(CoreBndr, CoreExpr)]
 131 findBinds core names = Maybe.mapMaybe (findBind (CoreSyn.flattenBinds $ cm_binds core)) names
 132
 133 -- | Extract a named bind from the given list of binds
 134 findBind :: [(CoreBndr, CoreExpr)] -> String -> Maybe (CoreBndr, CoreExpr)
 135 findBind binds lookfor =
 136   -- This ignores Recs and compares the name of the bind with lookfor,
 137   -- disregarding any namespaces in OccName and extra attributes in Name and
 138   -- Var.
 139   find (\(var, _) -> lookfor == (occNameString $ nameOccName $ getName var)) binds
 140
 141 -- | Flattens the given bind into the given signature and adds it to the
 142 --   session. Then (recursively) finds any functions it uses and does the same
 143 --   with them.
 144 flattenBind ::
 145   HsFunction                         -- The signature to flatten into
 146   -> (CoreBndr, CoreExpr)            -- The bind to flatten
 147   -> TranslatorState ()
 148
 149 flattenBind hsfunc bind@(var, expr) = do
 150   -- Flatten the function
 151   let flatfunc = flattenFunction hsfunc bind
 152   -- Propagate state variables
 153   let flatfunc' = propagateState hsfunc flatfunc
 154   -- Store the flat function in the session
 155   modA tsFlatFuncs (Map.insert hsfunc flatfunc')
 156   -- Flatten any functions used
 157   let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc')
 158   mapM_ resolvFunc used_hsfuncs
 159
 160 -- | Decide which incoming state variables will become state in the
 161 --   given function, and which will be propagate to other applied
 162 --   functions.
 163 propagateState ::
 164   HsFunction
 165   -> FlatFunction
 166   -> FlatFunction
 167
 168 propagateState hsfunc flatfunc =
 169     flatfunc {flat_defs = apps', flat_sigs = sigs'}
 170   where
 171     (olds, news) = unzip $ getStateSignals hsfunc flatfunc
 172     states' = zip olds news
 173     -- Find all signals used by all sigdefs
 174     uses = concatMap sigDefUses (flat_defs flatfunc)
 175     -- Find all signals that are used more than once (is there a
 176     -- prettier way to do this?)
 177     multiple_uses = uses List.\\ (List.nub uses)
 178     -- Find the states whose "old state" signal is used only once
 179     single_use_states = filter ((`notElem` multiple_uses) . fst) states'
 180     -- See if these single use states can be propagated
 181     (substate_sigss, apps') = unzip $ map (propagateState' single_use_states) (flat_defs flatfunc)
 182     substate_sigs = concat substate_sigss
 183     -- Mark any propagated state signals as SigSubState
 184     sigs' = map
 185       (\(id, info) -> (id, if id `elem` substate_sigs then info {sigUse = SigSubState} else info))
 186       (flat_sigs flatfunc)
 187
 188 -- | Propagate the state into a single function application.
 189 propagateState' ::
 190   [(SignalId, SignalId)]
 191                       -- ^ TODO
 192   -> SigDef           -- ^ The SigDef to process.
 193   -> ([SignalId], SigDef)
 194                       -- ^ Any signal ids that should become substates,
 195                       --   and the resulting application.
 196
 197 propagateState' states def =
 198     if (is_FApp def) then
 199       (our_old ++ our_new, def {appFunc = hsfunc'})
 200     else
 201       ([], def)
 202   where
 203     hsfunc = appFunc def
 204     args = appArgs def
 205     res = appRes def
 206     our_states = filter our_state states
 207     -- A state signal belongs in this function if the old state is
 208     -- passed in, and the new state returned
 209     our_state (old, new) =
 210       any (old `Foldable.elem`) args
 211       && new `Foldable.elem` res
 212     (our_old, our_new) = unzip our_states
 213     -- Mark the result
 214     zipped_res = zipValueMaps res (hsFuncRes hsfunc)
 215     res' = fmap (mark_state (zip our_new [0..])) zipped_res
 216     -- Mark the args
 217     zipped_args = zipWith zipValueMaps args (hsFuncArgs hsfunc)
 218     args' = map (fmap (mark_state (zip our_old [0..]))) zipped_args
 219     hsfunc' = hsfunc {hsFuncArgs = args', hsFuncRes = res'}
 220
 221     mark_state :: [(SignalId, StateId)] -> (SignalId, HsValueUse) -> HsValueUse
 222     mark_state states (id, use) =
 223       case lookup id states of
 224         Nothing -> use
 225         Just state_id -> State state_id
 226
 227 -- | Returns pairs of signals that should be mapped to state in this function.
 228 getStateSignals ::
 229   HsFunction                      -- | The function to look at
 230   -> FlatFunction                 -- | The function to look at
 231   -> [(SignalId, SignalId)]
 232         -- | TODO The state signals. The first is the state number, the second the
 233         --   signal to assign the current state to, the last is the signal
 234         --   that holds the new state.
 235
 236 getStateSignals hsfunc flatfunc =
 237   [(old_id, new_id)
 238     | (old_num, old_id) <- args
 239     , (new_num, new_id) <- res
 240     , old_num == new_num]
 241   where
 242     sigs = flat_sigs flatfunc
 243     -- Translate args and res to lists of (statenum, sigid)
 244     args = concat $ zipWith stateList (hsFuncArgs hsfunc) (flat_args flatfunc)
 245     res = stateList (hsFuncRes hsfunc) (flat_res flatfunc)
 246
 247 -- | Find the given function, flatten it and add it to the session. Then
 248 --   (recursively) do the same for any functions used.
 249 resolvFunc ::
 250   HsFunction        -- | The function to look for
 251   -> TranslatorState ()
 252
 253 resolvFunc hsfunc = do
 254   flatfuncmap <- getA tsFlatFuncs
 255   -- Don't do anything if there is already a flat function for this hsfunc or
 256   -- when it is a builtin function.
 257   Monad.unless (Map.member hsfunc flatfuncmap) $ do
 258   -- Not working with new builtins -- Monad.unless (elem hsfunc VHDL.builtin_hsfuncs) $ do
 259   -- New function, resolve it
 260   core <- getA tsCoreModule
 261   -- Find the named function
 262   let name = (hsFuncName hsfunc)
 263   let bind = findBind (CoreSyn.flattenBinds $ cm_binds core) name
 264   case bind of
 265     Nothing -> error $ "Couldn't find function " ++ name ++ " in current module."
 266     Just b  -> flattenBind hsfunc b
 267
 268 -- | Translate a top level function declaration to a HsFunction. i.e., which
 269 --   interface will be provided by this function. This function essentially
 270 --   defines the "calling convention" for hardware models.
 271 mkHsFunction ::
 272   Var.Var         -- ^ The function defined
 273   -> Type         -- ^ The function type (including arguments!)
 274   -> Bool         -- ^ Is this a stateful function?
 275   -> HsFunction   -- ^ The resulting HsFunction
 276
 277 mkHsFunction f ty stateful=
 278   HsFunction hsname hsargs hsres
 279   where
 280     hsname  = getOccString f
 281     (arg_tys, res_ty) = Type.splitFunTys ty
 282     (hsargs, hsres) =
 283       if stateful
 284       then
 285         let
 286           -- The last argument must be state
 287           state_ty = last arg_tys
 288           state    = useAsState (mkHsValueMap state_ty)
 289           -- All but the last argument are inports
 290           inports = map (useAsPort . mkHsValueMap)(init arg_tys)
 291           hsargs   = inports ++ [state]
 292           hsres    = case splitTupleType res_ty of
 293             -- Result type must be a two tuple (state, ports)
 294             Just [outstate_ty, outport_ty] -> if Type.coreEqType state_ty outstate_ty
 295               then
 296                 Tuple [state, useAsPort (mkHsValueMap outport_ty)]
 297               else
 298                 error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty)
 299             otherwise                -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports."
 300         in
 301           (hsargs, hsres)
 302       else
 303         -- Just use everything as a port
 304         (map (useAsPort . mkHsValueMap) arg_tys, useAsPort $ mkHsValueMap res_ty)
 305
 306 -- | Adds signal names to the given FlatFunction
 307 nameFlatFunction ::
 308   FlatFunction
 309   -> FlatFunction
 310
 311 nameFlatFunction flatfunc =
 312   -- Name the signals
 313   let
 314     s = flat_sigs flatfunc
 315     s' = map nameSignal s in
 316   flatfunc { flat_sigs = s' }
 317   where
 318     nameSignal :: (SignalId, SignalInfo) -> (SignalId, SignalInfo)
 319     nameSignal (id, info) =
 320       let hints = nameHints info in
 321       let parts = ("sig" : hints) ++ [show id] in
 322       let name = concat $ List.intersperse "_" parts in
 323       (id, info {sigName = Just name})
 324
 325 -- | Splits a tuple type into a list of element types, or Nothing if the type
 326 --   is not a tuple type.
 327 splitTupleType ::
 328   Type              -- ^ The type to split
 329   -> Maybe [Type]   -- ^ The tuples element types
 330
 331 splitTupleType ty =
 332   case Type.splitTyConApp_maybe ty of
 333     Just (tycon, args) -> if TyCon.isTupleTyCon tycon
 334       then
 335         Just args
 336       else
 337         Nothing
 338     Nothing -> Nothing
 339
 340 -- vim: set ts=8 sw=2 sts=2 expandtab: