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