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 Name
  11 import Data.Generics
  12 import NameEnv ( lookupNameEnv )
  13 import HscTypes ( cm_binds, cm_types )
  14 import MonadUtils ( liftIO )
  15 import Outputable ( showSDoc, ppr )
  16 import GHC.Paths ( libdir )
  17 import DynFlags ( defaultDynFlags )
  18 import List ( find )
  19
  20 main =
  21                 do
  22                         defaultErrorHandler defaultDynFlags $ do
  23                                 runGhc (Just libdir) $ do
  24                                         dflags <- getSessionDynFlags
  25                                         setSessionDynFlags dflags
  26                                         --target <- guessTarget "adder.hs" Nothing
  27                                         --liftIO (print (showSDoc (ppr (target))))
  28                                         --liftIO $ printTarget target
  29                                         --setTargets [target]
  30                                         --load LoadAllTargets
  31                                         --core <- GHC.compileToCoreSimplified "Adders.hs"
  32                                         core <- GHC.compileToCoreSimplified "Adders.hs"
  33                                         liftIO $ printBinds (cm_binds core)
  34                                         let bind = findBind "no_carry_adder" (cm_binds core)
  35                                         let NonRec var expr = bind
  36                                         liftIO $ putStr $ showSDoc $ ppr expr
  37                                         liftIO $ putStr "\n\n"
  38                                         liftIO $ putStr $ getEntity bind
  39                                         liftIO $ putStr $ getArchitecture bind
  40                                         return expr
  41
  42 printTarget (Target (TargetFile file (Just x)) obj Nothing) =
  43         print $ show file
  44
  45 printBinds [] = putStr "done\n\n"
  46 printBinds (b:bs) = do
  47         printBind b
  48         putStr "\n"
  49         printBinds bs
  50
  51 printBind (NonRec b expr) = do
  52         putStr "NonRec: "
  53         printBind' (b, expr)
  54
  55 printBind (Rec binds) = do
  56         putStr "Rec: \n"
  57         foldl1 (>>) (map printBind' binds)
  58
  59 printBind' (b, expr) = do
  60         putStr $ getOccString b
  61         --putStr $ showSDoc $ ppr expr
  62         putStr "\n"
  63
  64 findBind :: String -> [CoreBind] -> CoreBind
  65 findBind lookfor =
  66         -- This ignores Recs and compares the name of the bind with lookfor,
  67         -- disregarding any namespaces in OccName and extra attributes in Name and
  68         -- Var.
  69         Maybe.fromJust . find (\b -> case b of
  70                 Rec l -> False
  71                 NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
  72         )
  73
  74 -- Generate a port (or multiple for tuple types) in the given direction for
  75 -- each type given.
  76 getPortsForTys :: String -> String -> Int -> [Type] -> String
  77 getPortsForTys dir prefix num [] = ""
  78 getPortsForTys dir prefix num (t:ts) =
  79         (getPortsForTy dir (prefix ++ show num) t) ++ getPortsForTys dir prefix (num + 1) ts
  80
  81 getPortsForFunTy ty =
  82                 -- All of a function's arguments become IN ports, the result becomes on
  83                 -- (or more) OUT ports.
  84                 -- Drop the first ;\n
  85                 drop 2 (getPortsForTys "in" "portin" 0 args) ++ (getPortsForTy "out" "portout" res) ++ "\n"
  86         where
  87                 (args, res) = Type.splitFunTys ty
  88
  89 getPortsForTy   :: String -> String -> Type -> String
  90 getPortsForTy dir name ty =
  91         if (TyCon.isTupleTyCon tycon) then
  92                 -- Expand tuples we find
  93                 getPortsForTys dir name 0 args
  94         else -- Assume it's a type constructor application, ie simple data type
  95                 let
  96                         vhdlTy = showSDoc $ ppr $ TyCon.tyConName tycon;
  97                 in
  98                         ";\n\t" ++ name ++ " : " ++ dir ++ " " ++ vhdlTy
  99         where
 100                 (tycon, args) = Type.splitTyConApp ty
 101
 102 getEntity (NonRec var expr) =
 103                 "entity " ++ name ++ " is\n"
 104                 ++ "port (\n"
 105                 ++ getPortsForFunTy ty
 106           ++ ");\n"
 107                 ++ "end " ++ name ++ ";\n\n"
 108         where
 109                 name = (getOccString var)
 110                 ty = CoreUtils.exprType expr
 111
 112 -- Accepts a port name and an argument to map to it.
 113 -- Returns the appropriate line for in the port map
 114 getPortMapEntry binds portname (Var id) =
 115         "\t" ++ portname ++ " => " ++ signalname ++ "\n"
 116         where
 117                 Port signalname = Maybe.fromMaybe
 118                         (error $ "Argument " ++ getOccString id ++ "is unknown")
 119                         (lookup id binds)
 120
 121 getPortMapEntry binds _ a = error $ "Unsupported argument: " ++ (showSDoc $ ppr a)
 122
 123 getInstantiations ::
 124         PortNameMap                  -- The arguments that need to be applied to the
 125                                                                                                                          -- expression. Should always be the Args
 126                                                                                                                          -- constructor.
 127         -> [(CoreBndr, PortNameMap)] -- A list of bindings in effect
 128         -> CoreSyn.CoreExpr          -- The expression to generate an architecture for
 129         -> String                    -- The resulting VHDL code
 130
 131 -- A lambda expression binds the first argument (a) to the binder b.
 132 getInstantiations (Args (a:as)) binds (Lam b expr) =
 133         getInstantiations (Args as) ((b, a):binds) expr
 134
 135 -- A case expression that checks a single variable and has a single
 136 -- alternative, can be used to take tuples apart
 137 getInstantiations args binds (Case (Var v) b _ [res]) =
 138         case altcon of
 139                 DataAlt datacon ->
 140                         if (DataCon.isTupleCon datacon) then
 141                                 getInstantiations args binds' expr
 142                         else
 143                                 error "Data constructors other than tuples not supported"
 144                 otherwise ->
 145                         error "Case binders other than tuples not supported"
 146         where
 147                 binds' = (zip bind_vars tuple_ports) ++ binds
 148                 (altcon, bind_vars, expr) = res
 149                 -- Find the portnamemaps for each of the tuple's elements
 150                 Tuple tuple_ports = Maybe.fromMaybe
 151                         (error $ "Case expression uses unknown scrutinee " ++ getOccString v)
 152                         (lookup v binds)
 153
 154 -- An application is an instantiation of a component
 155 getInstantiations args binds app@(App expr arg) =
 156         --indent ++ "F:\n" ++ (getInstantiations (' ':indent) expr) ++ "\n" ++ indent ++ "A:\n" ++ (getInstantiations (' ':indent) arg) ++ "\n"
 157         "app : " ++ (getOccString f) ++ "\n"
 158         ++ "port map (\n"
 159         ++ concat (zipWith (getPortMapEntry binds) ["portin0", "portin1"] args)
 160         ++ ");\n"
 161         where
 162                 ((Var f), args) = collectArgs app
 163
 164 getInstantiations args binds expr = showSDoc $ ppr $ expr
 165
 166 getArchitecture (NonRec var expr) =
 167         "architecture structural of " ++ name ++ " is\n"
 168         ++ "begin\n"
 169         ++ getInstantiations (Args [Tuple [Port "portin0", Port "portin1"]]) [] expr
 170         ++ "end structural\n"
 171         where
 172                 name = (getOccString var)
 173                 ty = CoreUtils.exprType expr
 174
 175 data PortNameMap =
 176         Args [PortNameMap] -- Each of the submaps represent an argument to the
 177                            -- function. Should only occur at top level.
 178         | Tuple [PortNameMap]
 179         | Port  String