Translator.hs

   1 module Main(main) 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 -- The following modules come from the ForSyDe project. They are really
  22 -- internal modules, so ForSyDe.cabal has to be modified prior to installing
  23 -- ForSyDe to get access to these modules.
  24 import qualified ForSyDe.Backend.VHDL.AST as AST
  25 import qualified ForSyDe.Backend.VHDL.Ppr
  26 import qualified ForSyDe.Backend.Ppr
  27 -- This is needed for rendering the pretty printed VHDL
  28 import Text.PrettyPrint.HughesPJ (render)
  29
  30 main =
  31     do
  32       defaultErrorHandler defaultDynFlags $ do
  33         runGhc (Just libdir) $ do
  34           dflags <- getSessionDynFlags
  35           setSessionDynFlags dflags
  36           --target <- guessTarget "adder.hs" Nothing
  37           --liftIO (print (showSDoc (ppr (target))))
  38           --liftIO $ printTarget target
  39           --setTargets [target]
  40           --load LoadAllTargets
  41           --core <- GHC.compileToCoreSimplified "Adders.hs"
  42           core <- GHC.compileToCoreSimplified "Adders.hs"
  43           liftIO $ printBinds (cm_binds core)
  44           let bind = findBind "half_adder" (cm_binds core)
  45           let NonRec var expr = bind
  46           -- Turn bind into VHDL
  47           let vhdl = State.evalState (mkVHDL bind) (VHDLSession 0 builtin_funcs)
  48           liftIO $ putStr $ showSDoc $ ppr expr
  49           liftIO $ putStr "\n\n"
  50           liftIO $ putStr $ render $ ForSyDe.Backend.Ppr.ppr $ vhdl
  51           return expr
  52   where
  53     -- Turns the given bind into VHDL
  54     mkVHDL bind = do
  55       -- Get the function signature
  56       (name, f) <- mkHWFunction bind
  57       -- Add it to the session
  58       addFunc name f
  59       arch <- getArchitecture bind
  60       return arch
  61
  62 printTarget (Target (TargetFile file (Just x)) obj Nothing) =
  63   print $ show file
  64
  65 printBinds [] = putStr "done\n\n"
  66 printBinds (b:bs) = do
  67   printBind b
  68   putStr "\n"
  69   printBinds bs
  70
  71 printBind (NonRec b expr) = do
  72   putStr "NonRec: "
  73   printBind' (b, expr)
  74
  75 printBind (Rec binds) = do
  76   putStr "Rec: \n"
  77   foldl1 (>>) (map printBind' binds)
  78
  79 printBind' (b, expr) = do
  80   putStr $ getOccString b
  81   --putStr $ showSDoc $ ppr expr
  82   putStr "\n"
  83
  84 findBind :: String -> [CoreBind] -> CoreBind
  85 findBind lookfor =
  86   -- This ignores Recs and compares the name of the bind with lookfor,
  87   -- disregarding any namespaces in OccName and extra attributes in Name and
  88   -- Var.
  89   Maybe.fromJust . find (\b -> case b of
  90     Rec l -> False
  91     NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
  92   )
  93
  94 -- Accepts a port name and an argument to map to it.
  95 -- Returns the appropriate line for in the port map
  96 getPortMapEntry binds (Port portname) (Var id) =
  97   (Just (AST.unsafeVHDLBasicId portname)) AST.:=>: (AST.ADName (AST.NSimple (AST.unsafeVHDLBasicId signalname)))
  98   where
  99     Port signalname = Maybe.fromMaybe
 100       (error $ "Argument " ++ getOccString id ++ "is unknown")
 101       (lookup id binds)
 102
 103 getPortMapEntry binds _ a = error $ "Unsupported argument: " ++ (showSDoc $ ppr a)
 104
 105 getInstantiations ::
 106   [PortNameMap]                -- The arguments that need to be applied to the
 107                                -- expression.
 108   -> PortNameMap               -- The output ports that the expression should generate.
 109   -> [(CoreBndr, PortNameMap)] -- A list of bindings in effect
 110   -> CoreSyn.CoreExpr          -- The expression to generate an architecture for
 111   -> VHDLState [AST.ConcSm]    -- The resulting VHDL code
 112
 113 -- A lambda expression binds the first argument (a) to the binder b.
 114 getInstantiations (a:as) outs binds (Lam b expr) =
 115   getInstantiations as outs ((b, a):binds) expr
 116
 117 -- A case expression that checks a single variable and has a single
 118 -- alternative, can be used to take tuples apart
 119 getInstantiations args outs binds (Case (Var v) b _ [res]) =
 120   -- Split out the type of alternative constructor, the variables it binds
 121   -- and the expression to evaluate with the variables bound.
 122   let (altcon, bind_vars, expr) = res in
 123   case altcon of
 124     DataAlt datacon ->
 125       if (DataCon.isTupleCon datacon) then
 126         let
 127           -- Lookup the scrutinee (which must be a variable bound to a tuple) in
 128           -- the existing bindings list and get the portname map for each of
 129           -- it's elements.
 130           Tuple tuple_ports = Maybe.fromMaybe
 131             (error $ "Case expression uses unknown scrutinee " ++ getOccString v)
 132             (lookup v binds)
 133           -- Merge our existing binds with the new binds.
 134           binds' = (zip bind_vars tuple_ports) ++ binds
 135         in
 136           -- Evaluate the expression with the new binds list
 137           getInstantiations args outs binds' expr
 138       else
 139         error "Data constructors other than tuples not supported"
 140     otherwise ->
 141       error "Case binders other than tuples not supported"
 142
 143 -- An application is an instantiation of a component
 144 getInstantiations args outs binds app@(App expr arg) = do
 145   let ((Var f), fargs) = collectArgs app
 146       name = getOccString f
 147   if isTupleConstructor f
 148     then do
 149       -- Get the signals we should bind our results to
 150       let Tuple outports = outs
 151       -- Split the tuple constructor arguments into types and actual values.
 152       let (_, vals) = splitTupleConstructorArgs fargs
 153       -- Bind each argument to each output signal
 154       insts <- sequence $ zipWith
 155         (\outs' expr' -> getInstantiations args outs' binds expr')
 156         outports vals
 157       -- And join all the component instantiations together
 158       return $ concat insts
 159     else do
 160       -- This is an normal function application, which maps to a component
 161       -- instantiation.
 162       -- Lookup the hwfunction to instantiate
 163       HWFunction inports outport <- getHWFunc name
 164       -- Generate a unique name for the application
 165       appname <- uniqueName "app"
 166       -- Bind each of the input ports to an argument
 167       let inmaps = zipWith (getPortMapEntry binds) inports fargs
 168       -- Bind each of the output ports to our output signals
 169       let outmaps = mapOutputPorts outport outs
 170       -- Build and return a component instantiation
 171       let comp = AST.CompInsSm
 172             (AST.unsafeVHDLBasicId appname)
 173             (AST.IUEntity (AST.NSimple (AST.unsafeVHDLBasicId name)))
 174             (AST.PMapAspect (inmaps ++ outmaps))
 175       return [AST.CSISm comp]
 176
 177 getInstantiations args outs binds expr =
 178   error $ "Unsupported expression" ++ (showSDoc $ ppr $ expr)
 179
 180 -- Is the given name a (binary) tuple constructor
 181 isTupleConstructor :: Var.Var -> Bool
 182 isTupleConstructor var =
 183   Name.isWiredInName name
 184   && Name.nameModule name == tuple_mod
 185   && (Name.occNameString $ Name.nameOccName name) == "(,)"
 186   where
 187     name = Var.varName var
 188     mod = nameModule name
 189     tuple_mod = Module.mkModule (Module.stringToPackageId "ghc-prim") (Module.mkModuleName "GHC.Tuple")
 190
 191 -- Split arguments into type arguments and value arguments This is probably
 192 -- not really sufficient (not sure if Types can actually occur as value
 193 -- arguments...)
 194 splitTupleConstructorArgs :: [CoreExpr] -> ([CoreExpr], [CoreExpr])
 195 splitTupleConstructorArgs (e:es) =
 196   case e of
 197     Type t     -> (e:tys, vals)
 198     otherwise  -> (tys, e:vals)
 199   where
 200     (tys, vals) = splitTupleConstructorArgs es
 201
 202 mapOutputPorts ::
 203   PortNameMap         -- The output portnames of the component
 204   -> PortNameMap      -- The output portnames and/or signals to map these to
 205   -> [AST.AssocElem]  -- The resulting output ports
 206
 207 -- Map the output port of a component to the output port of the containing
 208 -- entity.
 209 mapOutputPorts (Port portname) (Port signalname) =
 210   [(Just (AST.unsafeVHDLBasicId portname)) AST.:=>: (AST.ADName (AST.NSimple (AST.unsafeVHDLBasicId signalname)))]
 211
 212 -- Map matching output ports in the tuple
 213 mapOutputPorts (Tuple ports) (Tuple signals) =
 214   concat (zipWith mapOutputPorts ports signals)
 215
 216 getArchitecture ::
 217   CoreBind                  -- The binder to expand into an architecture
 218   -> VHDLState AST.ArchBody -- The resulting architecture
 219
 220 getArchitecture (Rec _) = error "Recursive binders not supported"
 221
 222 getArchitecture (NonRec var expr) = do
 223   let name = (getOccString var)
 224   HWFunction inports outport <- getHWFunc name
 225   sess <- State.get
 226   insts <- getInstantiations inports outport [] expr
 227   return $ AST.ArchBody
 228     (AST.unsafeVHDLBasicId "structural")
 229     -- Use unsafe for now, to prevent pulling in ForSyDe error handling
 230     (AST.NSimple (AST.unsafeVHDLBasicId name))
 231     []
 232     (insts)
 233
 234 data PortNameMap =
 235   Tuple [PortNameMap]
 236   | Port  String
 237   deriving (Show)
 238
 239 -- Generate a port name map (or multiple for tuple types) in the given direction for
 240 -- each type given.
 241 getPortNameMapForTys :: String -> Int -> [Type] -> [PortNameMap]
 242 getPortNameMapForTys prefix num [] = []
 243 getPortNameMapForTys prefix num (t:ts) =
 244   (getPortNameMapForTy (prefix ++ show num) t) : getPortNameMapForTys prefix (num + 1) ts
 245
 246 getPortNameMapForTy :: String -> Type -> PortNameMap
 247 getPortNameMapForTy name ty =
 248   if (TyCon.isTupleTyCon tycon) then
 249     -- Expand tuples we find
 250     Tuple (getPortNameMapForTys name 0 args)
 251   else -- Assume it's a type constructor application, ie simple data type
 252     -- TODO: Add type?
 253     Port name
 254   where
 255     (tycon, args) = Type.splitTyConApp ty
 256
 257 data HWFunction = HWFunction { -- A function that is available in hardware
 258   inPorts   :: [PortNameMap],
 259   outPort   :: PortNameMap
 260   --entity    :: AST.EntityDec
 261 } deriving (Show)
 262
 263 -- Turns a CoreExpr describing a function into a description of its input and
 264 -- output ports.
 265 mkHWFunction ::
 266   CoreBind                                   -- The core binder to generate the interface for
 267   -> VHDLState (String, HWFunction)          -- The name of the function and its interface
 268
 269 mkHWFunction (NonRec var expr) =
 270     return (name, HWFunction inports outport)
 271   where
 272     name = (getOccString var)
 273     ty = CoreUtils.exprType expr
 274     (fargs, res) = Type.splitFunTys ty
 275     args = if length fargs == 1 then fargs else (init fargs)
 276     --state = if length fargs == 1 then () else (last fargs)
 277     inports = case args of
 278       -- Handle a single port specially, to prevent an extra 0 in the name
 279       [port] -> [getPortNameMapForTy "portin" port]
 280       ps     -> getPortNameMapForTys "portin" 0 ps
 281     outport = getPortNameMapForTy "portout" res
 282
 283 mkHWFunction (Rec _) =
 284   error "Recursive binders not supported"
 285
 286 data VHDLSession = VHDLSession {
 287   nameCount :: Int,                      -- A counter that can be used to generate unique names
 288   funcs     :: [(String, HWFunction)]    -- All functions available, indexed by name
 289 } deriving (Show)
 290
 291 type VHDLState = State.State VHDLSession
 292
 293 -- Add the function to the session
 294 addFunc :: String -> HWFunction -> VHDLState ()
 295 addFunc name f = do
 296   fs <- State.gets funcs -- Get the funcs element from the session
 297   State.modify (\x -> x {funcs = (name, f) : fs }) -- Prepend name and f
 298
 299 -- Lookup the function with the given name in the current session. Errors if
 300 -- it was not found.
 301 getHWFunc :: String -> VHDLState HWFunction
 302 getHWFunc name = do
 303   fs <- State.gets funcs -- Get the funcs element from the session
 304   return $ Maybe.fromMaybe
 305     (error $ "Function " ++ name ++ "is unknown? This should not happen!")
 306     (lookup name fs)
 307
 308 -- Makes the given name unique by appending a unique number.
 309 -- This does not do any checking against existing names, so it only guarantees
 310 -- uniqueness with other names generated by uniqueName.
 311 uniqueName :: String -> VHDLState String
 312 uniqueName name = do
 313   count <- State.gets nameCount -- Get the funcs element from the session
 314   State.modify (\s -> s {nameCount = count + 1})
 315   return $ name ++ "-" ++ (show count)
 316
 317 builtin_funcs =
 318   [
 319     ("hwxor", HWFunction [Port "a", Port "b"] (Port "o")),
 320     ("hwand", HWFunction [Port "a", Port "b"] (Port "o"))
 321   ]
 322
 323 -- vim: set ts=8 sw=2 sts=2 expandtab: