cλash/CLasH/Translator.hs

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