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