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 "inv" (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 getPortMapEntry ::
  95   SignalNameMap AST.VHDLId  -- The port name to bind to
  96   -> SignalNameMap AST.VHDLId
  97                             -- The signal or port to bind to it
  98   -> AST.AssocElem          -- The resulting port map entry
  99
 100 -- Accepts a port name and an argument to map to it.
 101 -- Returns the appropriate line for in the port map
 102 getPortMapEntry (Signal portname) (Signal signame) =
 103   (Just portname) AST.:=>: (AST.ADName (AST.NSimple signame))
 104
 105 getInstantiations ::
 106   [SignalNameMap AST.VHDLId]   -- The arguments that need to be applied to the
 107                                -- expression.
 108   -> SignalNameMap AST.VHDLId  -- The output ports that the expression should generate.
 109   -> [(CoreBndr, SignalNameMap AST.VHDLId)]
 110                                -- A list of bindings in effect
 111   -> CoreSyn.CoreExpr          -- The expression to generate an architecture for
 112   -> VHDLState ([AST.SigDec], [AST.ConcSm])
 113                                -- The resulting VHDL code
 114
 115 -- A lambda expression binds the first argument (a) to the binder b.
 116 getInstantiations (a:as) outs binds (Lam b expr) =
 117   getInstantiations as outs ((b, a):binds) expr
 118
 119 -- A case expression that checks a single variable and has a single
 120 -- alternative, can be used to take tuples apart
 121 getInstantiations args outs binds (Case (Var v) b _ [res]) =
 122   -- Split out the type of alternative constructor, the variables it binds
 123   -- and the expression to evaluate with the variables bound.
 124   let (altcon, bind_vars, expr) = res in
 125   case altcon of
 126     DataAlt datacon ->
 127       if (DataCon.isTupleCon datacon) then
 128         let
 129           -- Lookup the scrutinee (which must be a variable bound to a tuple) in
 130           -- the existing bindings list and get the portname map for each of
 131           -- it's elements.
 132           Tuple tuple_ports = Maybe.fromMaybe
 133             (error $ "Case expression uses unknown scrutinee " ++ getOccString v)
 134             (lookup v binds)
 135           -- Merge our existing binds with the new binds.
 136           binds' = (zip bind_vars tuple_ports) ++ binds
 137         in
 138           -- Evaluate the expression with the new binds list
 139           getInstantiations args outs binds' expr
 140       else
 141         error "Data constructors other than tuples not supported"
 142     otherwise ->
 143       error "Case binders other than tuples not supported"
 144
 145 -- An application is an instantiation of a component
 146 getInstantiations args outs binds app@(App expr arg) = do
 147   let ((Var f), fargs) = collectArgs app
 148       name = getOccString f
 149   if isTupleConstructor f
 150     then do
 151       -- Get the signals we should bind our results to
 152       let Tuple outports = outs
 153       -- Split the tuple constructor arguments into types and actual values.
 154       let (_, vals) = splitTupleConstructorArgs fargs
 155       -- Bind each argument to each output signal
 156       res <- sequence $ zipWith
 157         (\outs' expr' -> getInstantiations args outs' binds expr')
 158         outports vals
 159       -- res is a list of pairs of lists, so split out the signals and
 160       -- components into separate lists of lists
 161       let (sigs, comps) = unzip res
 162       -- And join all the signals and component instantiations together
 163       return $ (concat sigs, concat comps)
 164     else do
 165       -- This is an normal function application, which maps to a component
 166       -- instantiation.
 167       -- Lookup the hwfunction to instantiate
 168       HWFunction inports outport <- getHWFunc name
 169       -- Generate a unique name for the application
 170       appname <- uniqueName "app"
 171       -- Expand each argument to a signal or port name, possibly generating
 172       -- new signals and component instantiations
 173       (sigs, comps, args) <- expandArgs binds fargs
 174       -- Bind each of the input ports to the expanded signal or port
 175       let inmaps = zipWith getPortMapEntry inports args
 176       -- Bind each of the output ports to our output signals
 177       let outmaps = mapOutputPorts outport outs
 178       -- Build and return a component instantiation
 179       let comp = AST.CompInsSm
 180             (AST.unsafeVHDLBasicId appname)
 181             (AST.IUEntity (AST.NSimple (AST.unsafeVHDLBasicId name)))
 182             (AST.PMapAspect (inmaps ++ outmaps))
 183       return (sigs, (AST.CSISm comp) : comps)
 184
 185 getInstantiations args outs binds expr =
 186   error $ "Unsupported expression" ++ (showSDoc $ ppr $ expr)
 187
 188 expandExpr ::
 189   [(CoreBndr, SignalNameMap AST.VHDLId)]
 190                                          -- A list of bindings in effect
 191   -> CoreExpr                            -- The expression to expand
 192   -> VHDLState (
 193        [AST.SigDec],                     -- Needed signal declarations
 194        [AST.ConcSm],                     -- Needed component instantations and
 195                                          -- signal assignments.
 196        [SignalNameMap AST.VHDLId],       -- The signal names corresponding to
 197                                          -- the expression's arguments
 198        SignalNameMap AST.VHDLId)         -- The signal names corresponding to
 199                                          -- the expression's result.
 200 expandExpr binds (Lam b expr) = do
 201   -- Generate a new signal to which we will expect this argument to be bound.
 202   signal_name <- uniqueName ("arg-" ++ getOccString b)
 203   -- TODO: This uses the bit type hardcoded
 204   let (signal_id, signal_decl) = mkSignal signal_name vhdl_bit_ty
 205   -- Add the binder to the list of binds
 206   let binds' = (b, Signal signal_id) : binds
 207   -- Expand the rest of the expression
 208   (signal_decls, statements, arg_signals, res_signal) <- expandExpr binds' expr
 209   -- Properly merge the results
 210   return (signal_decl : signal_decls,
 211           statements,
 212           (Signal signal_id) : arg_signals,
 213           res_signal)
 214
 215 expandExpr binds (Var id) =
 216   return ([], [], [], Signal signal_id)
 217   where
 218     -- Lookup the id in our binds map
 219     Signal signal_id = Maybe.fromMaybe
 220       (error $ "Argument " ++ getOccString id ++ "is unknown")
 221       (lookup id binds)
 222
 223 expandExpr binds app@(App _ _) = do
 224   let ((Var f), args) = collectArgs app
 225   if isTupleConstructor f
 226     then
 227       expandBuildTupleExpr binds args
 228     else
 229       expandApplicationExpr binds (CoreUtils.exprType app) f args
 230
 231 expandExpr binds expr =
 232   error $ "Unsupported expression: " ++ (showSDoc $ ppr $ expr)
 233
 234 -- Expands the construction of a tuple into VHDL
 235 expandBuildTupleExpr ::
 236   [(CoreBndr, SignalNameMap AST.VHDLId)]
 237                                          -- A list of bindings in effect
 238   -> [CoreExpr]                          -- A list of expressions to put in the tuple
 239   -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId], SignalNameMap AST.VHDLId)
 240                                          -- See expandExpr
 241 expandBuildTupleExpr binds args =
 242   error $ "Tuple construction not supported"
 243
 244 -- Expands the application of argument to a function into VHDL
 245 expandApplicationExpr ::
 246   [(CoreBndr, SignalNameMap AST.VHDLId)]
 247                                          -- A list of bindings in effect
 248   -> Type                                -- The result type of the function call
 249   -> Var.Var                             -- The function to call
 250   -> [CoreExpr]                          -- A list of argumetns to apply to the function
 251   -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId], SignalNameMap AST.VHDLId)
 252                                          -- See expandExpr
 253 expandApplicationExpr binds ty f args = do
 254   let name = getOccString f
 255   -- Generate a unique name for the application
 256   appname <- uniqueName ("app-" ++ name)
 257   -- Lookup the hwfunction to instantiate
 258   HWFunction inports outport <- getHWFunc name
 259   -- Expand each of the args, so each of them is reduced to output signals
 260   (arg_signal_decls, arg_statements, arg_res_signals) <- expandArgs binds args
 261   -- Bind each of the input ports to the expanded arguments
 262   let inmaps = concat $ zipWith createAssocElems inports arg_res_signals
 263   -- Create signal names for our result
 264   let res_signal = getPortNameMapForTy (appname ++ "-out") ty
 265   -- Create the corresponding signal declarations
 266   let signal_decls = mkSignalsFromMap res_signal
 267   -- Bind each of the output ports to our output signals
 268   let outmaps = mapOutputPorts outport res_signal
 269   -- Instantiate the component
 270   let component = AST.CSISm $ AST.CompInsSm
 271         (AST.unsafeVHDLBasicId appname)
 272         (AST.IUEntity (AST.NSimple (AST.unsafeVHDLBasicId name)))
 273         (AST.PMapAspect (inmaps ++ outmaps))
 274   -- Merge the generated declarations
 275   return (
 276     signal_decls ++ arg_signal_decls,
 277     component : arg_statements,
 278     [], -- We don't take any extra arguments; we don't support higher order functions yet
 279     res_signal)
 280
 281 -- Creates a list of AssocElems (port map lines) that maps the given signals
 282 -- to the given ports.
 283 createAssocElems ::
 284   SignalNameMap AST.VHDLId      -- The port names to bind to
 285   -> SignalNameMap AST.VHDLId   -- The signals to bind to it
 286   -> [AST.AssocElem]            -- The resulting port map lines
 287
 288 createAssocElems (Signal port_id) (Signal signal_id) =
 289   [(Just port_id) AST.:=>: (AST.ADName (AST.NSimple signal_id))]
 290
 291 createAssocElems (Tuple ports) (Tuple signals) =
 292   concat $ zipWith createAssocElems ports signals
 293
 294 -- Generate a signal declaration for a signal with the given name and the
 295 -- given type and no value. Also returns the id of the signal.
 296 mkSignal :: String -> AST.TypeMark -> (AST.VHDLId, AST.SigDec)
 297 mkSignal name ty =
 298   (id, mkSignalFromId id ty)
 299   where
 300     id = AST.unsafeVHDLBasicId name
 301
 302 mkSignalFromId :: AST.VHDLId -> AST.TypeMark -> AST.SigDec
 303 mkSignalFromId id ty =
 304   AST.SigDec id ty Nothing
 305
 306 -- Generates signal declarations for all the signals in the given map
 307 mkSignalsFromMap ::
 308   SignalNameMap AST.VHDLId
 309   -> [AST.SigDec]
 310
 311 mkSignalsFromMap (Signal id) =
 312   -- TODO: This uses the bit type hardcoded
 313   [mkSignalFromId id vhdl_bit_ty]
 314
 315 mkSignalsFromMap (Tuple signals) =
 316   concat $ map mkSignalsFromMap signals
 317
 318 expandArgs ::
 319   [(CoreBndr, SignalNameMap AST.VHDLId)] -- A list of bindings in effect
 320   -> [CoreExpr]                          -- The arguments to expand
 321   -> VHDLState ([AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId])
 322                                          -- The resulting signal declarations,
 323                                          -- component instantiations and a
 324                                          -- VHDLName for each of the
 325                                          -- expressions passed in.
 326 expandArgs binds (e:exprs) = do
 327   -- Expand the first expression
 328   arg <- case e of
 329     -- A simple variable reference should be in our binds map
 330     Var id -> return $ let
 331         -- Lookup the id in our binds map
 332         Signal signalid = Maybe.fromMaybe
 333           (error $ "Argument " ++ getOccString id ++ "is unknown")
 334           (lookup id binds)
 335       in
 336         -- Create a VHDL name from the signal name
 337         Signal signalid
 338     -- Other expressions are unsupported
 339     otherwise -> error ("Unsupported expression used as argument: " ++ (showSDoc $ ppr e))
 340   -- Expand the rest
 341   (sigs, comps, args) <- expandArgs binds exprs
 342   -- Return all results
 343   return (sigs, comps, arg:args)
 344
 345 expandArgs _ [] = return ([], [], [])
 346
 347 -- Is the given name a (binary) tuple constructor
 348 isTupleConstructor :: Var.Var -> Bool
 349 isTupleConstructor var =
 350   Name.isWiredInName name
 351   && Name.nameModule name == tuple_mod
 352   && (Name.occNameString $ Name.nameOccName name) == "(,)"
 353   where
 354     name = Var.varName var
 355     mod = nameModule name
 356     tuple_mod = Module.mkModule (Module.stringToPackageId "ghc-prim") (Module.mkModuleName "GHC.Tuple")
 357
 358 -- Split arguments into type arguments and value arguments This is probably
 359 -- not really sufficient (not sure if Types can actually occur as value
 360 -- arguments...)
 361 splitTupleConstructorArgs :: [CoreExpr] -> ([CoreExpr], [CoreExpr])
 362 splitTupleConstructorArgs (e:es) =
 363   case e of
 364     Type t     -> (e:tys, vals)
 365     otherwise  -> (tys, e:vals)
 366   where
 367     (tys, vals) = splitTupleConstructorArgs es
 368
 369 mapOutputPorts ::
 370   SignalNameMap AST.VHDLId      -- The output portnames of the component
 371   -> SignalNameMap AST.VHDLId   -- The output portnames and/or signals to map these to
 372   -> [AST.AssocElem]            -- The resulting output ports
 373
 374 -- Map the output port of a component to the output port of the containing
 375 -- entity.
 376 mapOutputPorts (Signal portname) (Signal signalname) =
 377   [(Just portname) AST.:=>: (AST.ADName (AST.NSimple signalname))]
 378
 379 -- Map matching output ports in the tuple
 380 mapOutputPorts (Tuple ports) (Tuple signals) =
 381   concat (zipWith mapOutputPorts ports signals)
 382
 383 getArchitecture ::
 384   CoreBind                  -- The binder to expand into an architecture
 385   -> VHDLState AST.ArchBody -- The resulting architecture
 386
 387 getArchitecture (Rec _) = error "Recursive binders not supported"
 388
 389 getArchitecture (NonRec var expr) = do
 390   let name = (getOccString var)
 391   HWFunction inports outport <- getHWFunc name
 392   sess <- State.get
 393   (signal_decls, statements, arg_signals, res_signal) <- expandExpr [] expr
 394   let inport_assigns = concat $ zipWith createSignalAssignments arg_signals inports
 395   let outport_assigns = createSignalAssignments outport res_signal
 396   return $ AST.ArchBody
 397     (AST.unsafeVHDLBasicId "structural")
 398     -- Use unsafe for now, to prevent pulling in ForSyDe error handling
 399     (AST.NSimple (AST.unsafeVHDLBasicId name))
 400     (map AST.BDISD signal_decls)
 401     (inport_assigns ++ outport_assigns ++ statements)
 402
 403 -- Create concurrent assignments of one map of signals to another. The maps
 404 -- should have a similar form.
 405 createSignalAssignments ::
 406   SignalNameMap AST.VHDLId         -- The signals to assign to
 407   -> SignalNameMap AST.VHDLId      -- The signals to assign
 408   -> [AST.ConcSm]                  -- The resulting assignments
 409
 410 -- A simple assignment of one signal to another (greatly complicated because
 411 -- signal assignments can be conditional with multiple conditions in VHDL).
 412 createSignalAssignments (Signal dst) (Signal src) =
 413     [AST.CSSASm assign]
 414   where
 415     src_name  = AST.NSimple src
 416     src_expr  = AST.PrimName src_name
 417     src_wform = AST.Wform [AST.WformElem src_expr Nothing]
 418     dst_name  = (AST.NSimple dst)
 419     assign    = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
 420
 421 createSignalAssignments (Tuple dsts) (Tuple srcs) =
 422   concat $ zipWith createSignalAssignments dsts srcs
 423
 424 data SignalNameMap t =
 425   Tuple [SignalNameMap t]
 426   | Signal  t
 427   deriving (Show)
 428
 429 -- Generate a port name map (or multiple for tuple types) in the given direction for
 430 -- each type given.
 431 getPortNameMapForTys :: String -> Int -> [Type] -> [SignalNameMap AST.VHDLId]
 432 getPortNameMapForTys prefix num [] = []
 433 getPortNameMapForTys prefix num (t:ts) =
 434   (getPortNameMapForTy (prefix ++ show num) t) : getPortNameMapForTys prefix (num + 1) ts
 435
 436 getPortNameMapForTy :: String -> Type -> SignalNameMap AST.VHDLId
 437 getPortNameMapForTy name ty =
 438   if (TyCon.isTupleTyCon tycon) then
 439     -- Expand tuples we find
 440     Tuple (getPortNameMapForTys name 0 args)
 441   else -- Assume it's a type constructor application, ie simple data type
 442     -- TODO: Add type?
 443     Signal (AST.unsafeVHDLBasicId name)
 444   where
 445     (tycon, args) = Type.splitTyConApp ty
 446
 447 data HWFunction = HWFunction { -- A function that is available in hardware
 448   inPorts   :: [SignalNameMap AST.VHDLId],
 449   outPort   :: SignalNameMap AST.VHDLId
 450   --entity    :: AST.EntityDec
 451 } deriving (Show)
 452
 453 -- Turns a CoreExpr describing a function into a description of its input and
 454 -- output ports.
 455 mkHWFunction ::
 456   CoreBind                                   -- The core binder to generate the interface for
 457   -> VHDLState (String, HWFunction)          -- The name of the function and its interface
 458
 459 mkHWFunction (NonRec var expr) =
 460     return (name, HWFunction inports outport)
 461   where
 462     name = (getOccString var)
 463     ty = CoreUtils.exprType expr
 464     (fargs, res) = Type.splitFunTys ty
 465     args = if length fargs == 1 then fargs else (init fargs)
 466     --state = if length fargs == 1 then () else (last fargs)
 467     inports = case args of
 468       -- Handle a single port specially, to prevent an extra 0 in the name
 469       [port] -> [getPortNameMapForTy "portin" port]
 470       ps     -> getPortNameMapForTys "portin" 0 ps
 471     outport = getPortNameMapForTy "portout" res
 472
 473 mkHWFunction (Rec _) =
 474   error "Recursive binders not supported"
 475
 476 data VHDLSession = VHDLSession {
 477   nameCount :: Int,                      -- A counter that can be used to generate unique names
 478   funcs     :: [(String, HWFunction)]    -- All functions available, indexed by name
 479 } deriving (Show)
 480
 481 type VHDLState = State.State VHDLSession
 482
 483 -- Add the function to the session
 484 addFunc :: String -> HWFunction -> VHDLState ()
 485 addFunc name f = do
 486   fs <- State.gets funcs -- Get the funcs element from the session
 487   State.modify (\x -> x {funcs = (name, f) : fs }) -- Prepend name and f
 488
 489 -- Lookup the function with the given name in the current session. Errors if
 490 -- it was not found.
 491 getHWFunc :: String -> VHDLState HWFunction
 492 getHWFunc name = do
 493   fs <- State.gets funcs -- Get the funcs element from the session
 494   return $ Maybe.fromMaybe
 495     (error $ "Function " ++ name ++ "is unknown? This should not happen!")
 496     (lookup name fs)
 497
 498 -- Makes the given name unique by appending a unique number.
 499 -- This does not do any checking against existing names, so it only guarantees
 500 -- uniqueness with other names generated by uniqueName.
 501 uniqueName :: String -> VHDLState String
 502 uniqueName name = do
 503   count <- State.gets nameCount -- Get the funcs element from the session
 504   State.modify (\s -> s {nameCount = count + 1})
 505   return $ name ++ "-" ++ (show count)
 506
 507 -- Shortcut
 508 mkVHDLId :: String -> AST.VHDLId
 509 mkVHDLId = AST.unsafeVHDLBasicId
 510
 511 builtin_funcs =
 512   [
 513     ("hwxor", HWFunction [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
 514     ("hwand", HWFunction [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
 515     ("hwnot", HWFunction [Signal $ mkVHDLId "i"] (Signal $ mkVHDLId "o"))
 516   ]
 517
 518 vhdl_bit_ty :: AST.TypeMark
 519 vhdl_bit_ty = AST.unsafeVHDLBasicId "Bit"
 520
 521 -- vim: set ts=8 sw=2 sts=2 expandtab: