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
  21 main =
  22                 do
  23                         defaultErrorHandler defaultDynFlags $ do
  24                                 runGhc (Just libdir) $ do
  25                                         dflags <- getSessionDynFlags
  26                                         setSessionDynFlags dflags
  27                                         --target <- guessTarget "adder.hs" Nothing
  28                                         --liftIO (print (showSDoc (ppr (target))))
  29                                         --liftIO $ printTarget target
  30                                         --setTargets [target]
  31                                         --load LoadAllTargets
  32                                         --core <- GHC.compileToCoreSimplified "Adders.hs"
  33                                         core <- GHC.compileToCoreSimplified "Adders.hs"
  34                                         liftIO $ printBinds (cm_binds core)
  35                                         let bind = findBind "half_adder" (cm_binds core)
  36                                         let NonRec var expr = bind
  37                                         liftIO $ putStr $ showSDoc $ ppr expr
  38                                         liftIO $ putStr "\n\n"
  39                                         liftIO $ putStr $ getEntity bind
  40                                         liftIO $ putStr $ getArchitecture bind
  41                                         return expr
  42
  43 printTarget (Target (TargetFile file (Just x)) obj Nothing) =
  44         print $ show file
  45
  46 printBinds [] = putStr "done\n\n"
  47 printBinds (b:bs) = do
  48         printBind b
  49         putStr "\n"
  50         printBinds bs
  51
  52 printBind (NonRec b expr) = do
  53         putStr "NonRec: "
  54         printBind' (b, expr)
  55
  56 printBind (Rec binds) = do
  57         putStr "Rec: \n"
  58         foldl1 (>>) (map printBind' binds)
  59
  60 printBind' (b, expr) = do
  61         putStr $ getOccString b
  62         --putStr $ showSDoc $ ppr expr
  63         putStr "\n"
  64
  65 findBind :: String -> [CoreBind] -> CoreBind
  66 findBind lookfor =
  67         -- This ignores Recs and compares the name of the bind with lookfor,
  68         -- disregarding any namespaces in OccName and extra attributes in Name and
  69         -- Var.
  70         Maybe.fromJust . find (\b -> case b of
  71                 Rec l -> False
  72                 NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
  73         )
  74
  75 -- Generate a port (or multiple for tuple types) in the given direction for
  76 -- each type given.
  77 getPortsForTys :: String -> String -> Int -> [Type] -> String
  78 getPortsForTys dir prefix num [] = ""
  79 getPortsForTys dir prefix num (t:ts) =
  80         (getPortsForTy dir (prefix ++ show num) t) ++ getPortsForTys dir prefix (num + 1) ts
  81
  82 getPortsForFunTy ty =
  83                 -- All of a function's arguments become IN ports, the result becomes on
  84                 -- (or more) OUT ports.
  85                 -- Drop the first ;\n
  86                 drop 2 (getPortsForTys "in" "portin" 0 args) ++ (getPortsForTy "out" "portout" res) ++ "\n"
  87         where
  88                 (args, res) = Type.splitFunTys ty
  89
  90 getPortsForTy   :: String -> String -> Type -> String
  91 getPortsForTy dir name ty =
  92         if (TyCon.isTupleTyCon tycon) then
  93                 -- Expand tuples we find
  94                 getPortsForTys dir name 0 args
  95         else -- Assume it's a type constructor application, ie simple data type
  96                 let
  97                         vhdlTy = showSDoc $ ppr $ TyCon.tyConName tycon;
  98                 in
  99                         ";\n\t" ++ name ++ " : " ++ dir ++ " " ++ vhdlTy
 100         where
 101                 (tycon, args) = Type.splitTyConApp ty
 102
 103 getEntity (NonRec var expr) =
 104                 "entity " ++ name ++ " is\n"
 105                 ++ "port (\n"
 106                 ++ getPortsForFunTy ty
 107           ++ ");\n"
 108                 ++ "end " ++ name ++ ";\n\n"
 109         where
 110                 name = (getOccString var)
 111                 ty = CoreUtils.exprType expr
 112
 113 -- Accepts a port name and an argument to map to it.
 114 -- Returns the appropriate line for in the port map
 115 getPortMapEntry binds portname (Var id) =
 116         "\t" ++ portname ++ " => " ++ signalname ++ "\n"
 117         where
 118                 Port signalname = Maybe.fromMaybe
 119                         (error $ "Argument " ++ getOccString id ++ "is unknown")
 120                         (lookup id binds)
 121
 122 getPortMapEntry binds _ a = error $ "Unsupported argument: " ++ (showSDoc $ ppr a)
 123
 124 getInstantiations ::
 125         PortNameMap                  -- The arguments that need to be applied to the
 126                                                                                                                          -- expression. Should always be the Args
 127                                                                                                                          -- constructor.
 128         -> PortNameMap               -- The output ports that the expression should generate.
 129         -> [(CoreBndr, PortNameMap)] -- A list of bindings in effect
 130         -> CoreSyn.CoreExpr          -- The expression to generate an architecture for
 131         -> String                    -- The resulting VHDL code
 132
 133 -- A lambda expression binds the first argument (a) to the binder b.
 134 getInstantiations (Args (a:as)) outs binds (Lam b expr) =
 135         getInstantiations (Args as) outs ((b, a):binds) expr
 136
 137 -- A case expression that checks a single variable and has a single
 138 -- alternative, can be used to take tuples apart
 139 getInstantiations args outs binds (Case (Var v) b _ [res]) =
 140         case altcon of
 141                 DataAlt datacon ->
 142                         if (DataCon.isTupleCon datacon) then
 143                                 getInstantiations args outs binds' expr
 144                         else
 145                                 error "Data constructors other than tuples not supported"
 146                 otherwise ->
 147                         error "Case binders other than tuples not supported"
 148         where
 149                 binds' = (zip bind_vars tuple_ports) ++ binds
 150                 (altcon, bind_vars, expr) = res
 151                 -- Find the portnamemaps for each of the tuple's elements
 152                 Tuple tuple_ports = Maybe.fromMaybe
 153                         (error $ "Case expression uses unknown scrutinee " ++ getOccString v)
 154                         (lookup v binds)
 155
 156 -- An application is an instantiation of a component
 157 getInstantiations args outs binds app@(App expr arg) =
 158         if isTupleConstructor f then
 159                 let
 160                         Tuple outports = outs
 161                         (tys, vals) = splitTupleConstructorArgs fargs
 162                 in
 163                         concat $ zipWith
 164                                 (\outs' expr' -> getInstantiations args outs' binds expr')
 165                                 outports vals
 166         else
 167                 --indent ++ "F:\n" ++ (getInstantiations (' ':indent) expr) ++ "\n" ++ indent ++ "A:\n" ++ (getInstantiations (' ':indent) arg) ++ "\n"
 168                 "app : " ++ (getOccString f) ++ "\n"
 169                 ++ "port map (\n"
 170                 -- Map input ports of f
 171                 ++ concat (zipWith (getPortMapEntry binds) ["portin0", "portin1"] fargs)
 172                 -- Map output ports of f
 173                 ++ mapOutputPorts (Port "portout") outs
 174                 ++ ");\n"
 175         where
 176                 ((Var f), fargs) = collectArgs app
 177
 178 getInstantiations args outs binds expr =
 179         error $ "Unsupported expression" ++ (showSDoc $ ppr $ expr)
 180
 181 -- Is the given name a (binary) tuple constructor
 182 isTupleConstructor :: Var.Var -> Bool
 183 isTupleConstructor var =
 184         Name.isWiredInName name
 185         && Name.nameModule name == tuple_mod
 186         && (Name.occNameString $ Name.nameOccName name) == "(,)"
 187         where
 188                 name = Var.varName var
 189                 mod = nameModule name
 190                 tuple_mod = Module.mkModule (Module.stringToPackageId "ghc-prim") (Module.mkModuleName "GHC.Tuple")
 191
 192 -- Split arguments into type arguments and value arguments This is probably
 193 -- not really sufficient (not sure if Types can actually occur as value
 194 -- arguments...)
 195 splitTupleConstructorArgs :: [CoreExpr] -> ([CoreExpr], [CoreExpr])
 196 splitTupleConstructorArgs (e:es) =
 197         case e of
 198                 Type t     -> (e:tys, vals)
 199                 otherwise  -> (tys, e:vals)
 200         where
 201                 (tys, vals) = splitTupleConstructorArgs es
 202
 203 -- Map the output port of a component to the output port of the containing
 204 -- entity.
 205 mapOutputPorts (Port port) (Port signal) =
 206         "\t" ++ port ++ " => " ++ signal ++ "\n"
 207
 208 -- Map matching output ports in the tuple
 209 mapOutputPorts (Tuple ports) (Tuple signals) =
 210         concat (zipWith mapOutputPorts ports signals)
 211
 212 getArchitecture (NonRec var expr) =
 213         "architecture structural of " ++ name ++ " is\n"
 214         ++ "begin\n"
 215         ++ getInstantiations (Args inportnames) outport [] expr
 216         ++ "end structural\n"
 217         where
 218                 name = (getOccString var)
 219                 ty = CoreUtils.exprType expr
 220                 (fargs, res) = Type.splitFunTys ty
 221                 --state = if length fargs == 1 then () else (last fargs)
 222                 ports = if length fargs == 1 then fargs else (init fargs)
 223                 inportnames = case ports of
 224                         [port] -> [getPortNameMapForTy "portin" port]
 225                         ps     -> getPortNameMapForTys "portin" 0 ps
 226                 outport = getPortNameMapForTy "portout" res
 227
 228 data PortNameMap =
 229         Args [PortNameMap] -- Each of the submaps represent an argument to the
 230                            -- function. Should only occur at top level.
 231         | Tuple [PortNameMap]
 232         | Port  String
 233
 234 -- Generate a port name map (or multiple for tuple types) in the given direction for
 235 -- each type given.
 236 getPortNameMapForTys :: String -> Int -> [Type] -> [PortNameMap]
 237 getPortNameMapForTys prefix num [] = []
 238 getPortNameMapForTys prefix num (t:ts) =
 239         (getPortNameMapForTy (prefix ++ show num) t) : getPortNameMapForTys prefix (num + 1) ts
 240
 241 getPortNameMapForTy     :: String -> Type -> PortNameMap
 242 getPortNameMapForTy name ty =
 243         if (TyCon.isTupleTyCon tycon) then
 244                 -- Expand tuples we find
 245                 Tuple (getPortNameMapForTys name 0 args)
 246         else -- Assume it's a type constructor application, ie simple data type
 247                 -- TODO: Add type?
 248                 Port name
 249         where
 250                 (tycon, args) = Type.splitTyConApp ty