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