-}
-- Not really an adder either, but a slightly more complex example
inv :: Bit -> Bit
-inv a = hwnot a
+inv a = let r = hwnot a in r
-- Not really an adder either, but a slightly more complex example
invinv :: Bit -> Bit
(rest, cin) = rec_adder (as, bs)
(s, cout) = full_adder (a, b, cin)
+foo = id
+add, sub :: Int -> Int -> Int
+add a b = a + b
+sub a b = a - b
+
+highordtest = \x ->
+ let s = foo x
+ in
+ case s of
+ (a, b) ->
+ case a of
+ High -> add
+ Low -> let
+ op' = case b of
+ High -> sub
+ Low -> \c d -> c
+ in
+ \c d -> op' d c
+
-- Four bit adder, using the continous adder below
-- [a] -> [b] -> ([s], cout)
--con_adder_4 as bs =
import qualified HsTypes
import qualified HsBinds
import qualified RdrName
+import qualified Name
import qualified OccName
import qualified TysWiredIn
import qualified Bag
import qualified DynFlags
import qualified SrcLoc
+import qualified CoreSyn
+import qualified Var
+import qualified Unique
+import qualified CoreUtils
import GhcTools
import HsTools
where
(tycon, args) = Type.splitTyConApp ty
[len, el_ty] = args
+
+-- Is this a wild binder?
+is_wild :: CoreSyn.CoreBndr -> Bool
+-- wild binders have a particular unique, that we copied from MkCore.lhs to
+-- here. However, this comparison didn't work, so we'll just check the
+-- occstring for now... TODO
+--(Var.varUnique bndr) == (Unique.mkBuiltinUnique 1)
+is_wild bndr = "wild" == (OccName.occNameString . Name.nameOccName . Var.varName) bndr
+
+-- Is the given core expression a lambda abstraction?
+is_lam :: CoreSyn.CoreExpr -> Bool
+is_lam (CoreSyn.Lam _ _) = True
+is_lam _ = False
+
+-- Is the given core expression of a function type?
+is_fun :: CoreSyn.CoreExpr -> Bool
+is_fun = Type.isFunTy . CoreUtils.exprType
import Translator
main = do
- makeVHDL "Alu.hs" "exec" True
\ No newline at end of file
+ makeVHDL "Adders.hs" "highordtest" True
\ No newline at end of file
--- /dev/null
+--
+-- Functions to bring a Core expression in normal form. This module provides a
+-- top level function "normalize", and defines the actual transformation passes that
+-- are performed.
+--
+module Normalize (normalize) where
+
+-- Standard modules
+import Debug.Trace
+import qualified Maybe
+import qualified Control.Monad as Monad
+
+-- GHC API
+import CoreSyn
+import qualified UniqSupply
+import qualified CoreUtils
+import qualified Type
+import qualified Id
+import qualified UniqSet
+import qualified CoreFVs
+import Outputable ( showSDoc, ppr, nest )
+
+-- Local imports
+import NormalizeTypes
+import NormalizeTools
+import CoreTools
+
+--------------------------------
+-- Start of transformations
+--------------------------------
+
+--------------------------------
+-- η abstraction
+--------------------------------
+eta, etatop :: Transform
+eta expr | is_fun expr && not (is_lam expr) = do
+ let arg_ty = (fst . Type.splitFunTy . CoreUtils.exprType) expr
+ id <- mkInternalVar "param" arg_ty
+ change (Lam id (App expr (Var id)))
+-- Leave all other expressions unchanged
+eta e = return e
+etatop = notapplied ("eta", eta)
+
+--------------------------------
+-- β-reduction
+--------------------------------
+beta, betatop :: Transform
+-- Substitute arg for x in expr
+beta (App (Lam x expr) arg) = change $ substitute [(x, arg)] expr
+-- Propagate the application into the let
+beta (App (Let binds expr) arg) = change $ Let binds (App expr arg)
+-- Propagate the application into each of the alternatives
+beta (App (Case scrut b ty alts) arg) = change $ Case scrut b ty' alts'
+ where
+ alts' = map (\(con, bndrs, expr) -> (con, bndrs, (App expr arg))) alts
+ (_, ty') = Type.splitFunTy ty
+-- Leave all other expressions unchanged
+beta expr = return expr
+-- Perform this transform everywhere
+betatop = everywhere ("beta", beta)
+
+--------------------------------
+-- let recursification
+--------------------------------
+letrec, letrectop :: Transform
+letrec (Let (NonRec b expr) res) = change $ Let (Rec [(b, expr)]) res
+-- Leave all other expressions unchanged
+letrec expr = return expr
+-- Perform this transform everywhere
+letrectop = everywhere ("letrec", letrec)
+
+--------------------------------
+-- let simplification
+--------------------------------
+letsimpl, letsimpltop :: Transform
+-- Don't simplifiy lets that are already simple
+letsimpl expr@(Let _ (Var _)) = return expr
+-- Put the "in ..." value of a let in its own binding, but not when the
+-- expression has a function type (to prevent loops with inlinefun).
+letsimpl (Let (Rec binds) expr) | not $ is_fun expr = do
+ id <- mkInternalVar "foo" (CoreUtils.exprType expr)
+ let bind = (id, expr)
+ change $ Let (Rec (bind:binds)) (Var id)
+-- Leave all other expressions unchanged
+letsimpl expr = return expr
+-- Perform this transform everywhere
+letsimpltop = everywhere ("letsimpl", letsimpl)
+
+--------------------------------
+-- let flattening
+--------------------------------
+letflat, letflattop :: Transform
+letflat (Let (Rec binds) expr) = do
+ -- Turn each binding into a list of bindings (possibly containing just one
+ -- element, of course)
+ bindss <- Monad.mapM flatbind binds
+ -- Concat all the bindings
+ let binds' = concat bindss
+ -- Return the new let. We don't use change here, since possibly nothing has
+ -- changed. If anything has changed, flatbind has already flagged that
+ -- change.
+ return $ Let (Rec binds') expr
+ where
+ -- Turns a binding of a let into a multiple bindings, or any other binding
+ -- into a list with just that binding
+ flatbind :: (CoreBndr, CoreExpr) -> TransformMonad [(CoreBndr, CoreExpr)]
+ flatbind (b, Let (Rec binds) expr) = change ((b, expr):binds)
+ flatbind (b, expr) = return [(b, expr)]
+-- Leave all other expressions unchanged
+letflat expr = return expr
+-- Perform this transform everywhere
+letflattop = everywhere ("letflat", letflat)
+
+--------------------------------
+-- Simple let binding removal
+--------------------------------
+-- Remove a = b bindings from let expressions everywhere
+letremovetop :: Transform
+letremovetop = everywhere ("letremove", inlinebind (\(b, e) -> case e of (Var v) -> True; otherwise -> False))
+
+--------------------------------
+-- Function inlining
+--------------------------------
+-- Remove a = B bindings, with B :: a -> b, from let expressions everywhere.
+-- This is a tricky function, which is prone to create loops in the
+-- transformations. To fix this, we make sure that no transformation will
+-- create a new let binding with a function type. These other transformations
+-- will just not work on those function-typed values at first, but the other
+-- transformations (in particular β-reduction) should make sure that the type
+-- of those values eventually becomes primitive.
+inlinefuntop :: Transform
+inlinefuntop = everywhere ("inlinefun", inlinebind (Type.isFunTy . CoreUtils.exprType . snd))
+
+--------------------------------
+-- Scrutinee simplification
+--------------------------------
+scrutsimpl,scrutsimpltop :: Transform
+-- Don't touch scrutinees that are already simple
+scrutsimpl expr@(Case (Var _) _ _ _) = return expr
+-- Replace all other cases with a let that binds the scrutinee and a new
+-- simple scrutinee, but not when the scrutinee is a function type (to prevent
+-- loops with inlinefun, though I don't think a scrutinee can have a function
+-- type...)
+scrutsimpl (Case scrut b ty alts) | not $ is_fun scrut = do
+ id <- mkInternalVar "scrut" (CoreUtils.exprType scrut)
+ change $ Let (Rec [(id, scrut)]) (Case (Var id) b ty alts)
+-- Leave all other expressions unchanged
+scrutsimpl expr = return expr
+-- Perform this transform everywhere
+scrutsimpltop = everywhere ("scrutsimpl", scrutsimpl)
+
+--------------------------------
+-- Case binder wildening
+--------------------------------
+casewild, casewildtop :: Transform
+casewild expr@(Case scrut b ty alts) = do
+ (bindingss, alts') <- (Monad.liftM unzip) $ mapM doalt alts
+ let bindings = concat bindingss
+ -- Replace the case with a let with bindings and a case
+ let newlet = (Let (Rec bindings) (Case scrut b ty alts'))
+ -- If there are no non-wild binders, or this case is already a simple
+ -- selector (i.e., a single alt with exactly one binding), already a simple
+ -- selector altan no bindings (i.e., no wild binders in the original case),
+ -- don't change anything, otherwise, replace the case.
+ if null bindings || length alts == 1 && length bindings == 1 then return expr else change newlet
+ where
+ -- Generate a single wild binder, since they are all the same
+ wild = Id.mkWildId
+ -- Wilden the binders of one alt, producing a list of bindings as a
+ -- sideeffect.
+ doalt :: CoreAlt -> TransformMonad ([(CoreBndr, CoreExpr)], CoreAlt)
+ doalt (con, bndrs, expr) = do
+ bindings_maybe <- Monad.zipWithM mkextracts bndrs [0..]
+ let bindings = Maybe.catMaybes bindings_maybe
+ -- We replace the binders with wild binders only. We can leave expr
+ -- unchanged, since the new bindings bind the same vars as the original
+ -- did.
+ let newalt = (con, wildbndrs, expr)
+ return (bindings, newalt)
+ where
+ -- Make all binders wild
+ wildbndrs = map (\bndr -> Id.mkWildId (Id.idType bndr)) bndrs
+ -- Creates a case statement to retrieve the ith element from the scrutinee
+ -- and binds that to b.
+ mkextracts :: CoreBndr -> Int -> TransformMonad (Maybe (CoreBndr, CoreExpr))
+ mkextracts b i =
+ if is_wild b || Type.isFunTy (Id.idType b)
+ -- Don't create extra bindings for binders that are already wild, or
+ -- for binders that bind function types (to prevent loops with
+ -- inlinefun).
+ then return Nothing
+ else do
+ -- Create on new binder that will actually capture a value in this
+ -- case statement, and return it
+ let bty = (Id.idType b)
+ id <- mkInternalVar "sel" bty
+ let binders = take i wildbndrs ++ [id] ++ drop (i+1) wildbndrs
+ return $ Just (b, Case scrut b bty [(con, binders, Var id)])
+-- Leave all other expressions unchanged
+casewild expr = return expr
+-- Perform this transform everywhere
+casewildtop = everywhere ("casewild", casewild)
+
+--------------------------------
+-- Case value simplification
+--------------------------------
+casevalsimpl, casevalsimpltop :: Transform
+casevalsimpl expr@(Case scrut b ty alts) = do
+ -- Try to simplify each alternative, resulting in an optional binding and a
+ -- new alternative.
+ (bindings_maybe, alts') <- (Monad.liftM unzip) $ mapM doalt alts
+ let bindings = Maybe.catMaybes bindings_maybe
+ -- Create a new let around the case, that binds of the cases values.
+ let newlet = Let (Rec bindings) (Case scrut b ty alts')
+ -- If there were no values that needed and allowed simplification, don't
+ -- change the case.
+ if null bindings then return expr else change newlet
+ where
+ doalt :: CoreAlt -> TransformMonad (Maybe (CoreBndr, CoreExpr), CoreAlt)
+ -- Don't simplify values that are already simple
+ doalt alt@(con, bndrs, Var _) = return (Nothing, alt)
+ -- Simplify each alt by creating a new id, binding the case value to it and
+ -- replacing the case value with that id. Only do this when the case value
+ -- does not use any of the binders bound by this alternative, for that would
+ -- cause those binders to become unbound when moving the value outside of
+ -- the case statement. Also, don't create a binding for function-typed
+ -- expressions, to prevent loops with inlinefun.
+ doalt (con, bndrs, expr) | (not usesvars) && (not $ is_fun expr) = do
+ id <- mkInternalVar "caseval" (CoreUtils.exprType expr)
+ -- We don't flag a change here, since casevalsimpl will do that above
+ -- based on Just we return here.
+ return $ (Just (id, expr), (con, bndrs, Var id))
+ -- Find if any of the binders are used by expr
+ where usesvars = (not . UniqSet.isEmptyUniqSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs))) expr
+ -- Don't simplify anything else
+ doalt alt = return (Nothing, alt)
+-- Leave all other expressions unchanged
+casevalsimpl expr = return expr
+-- Perform this transform everywhere
+casevalsimpltop = everywhere ("casevalsimpl", casevalsimpl)
+
+--------------------------------
+-- Case removal
+--------------------------------
+-- Remove case statements that have only a single alternative and only wild
+-- binders.
+caseremove, caseremovetop :: Transform
+-- Replace a useless case by the value of its single alternative
+caseremove (Case scrut b ty [(con, bndrs, expr)]) | not usesvars = change expr
+ -- Find if any of the binders are used by expr
+ where usesvars = (not . UniqSet.isEmptyUniqSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs))) expr
+-- Leave all other expressions unchanged
+caseremove expr = return expr
+-- Perform this transform everywhere
+caseremovetop = everywhere ("caseremove", caseremove)
+
+--------------------------------
+-- Application simplification
+--------------------------------
+-- Make sure that all arguments in an application are simple variables.
+appsimpl, appsimpltop :: Transform
+-- Don't simplify arguments that are already simple
+appsimpl expr@(App f (Var _)) = return expr
+-- Simplify all arguments that do not have a function type (to prevent loops
+-- with inlinefun) and is not a type argument. Do this by introducing a new
+-- Let that binds the argument and passing the new binder in the application.
+appsimpl (App f expr) | (not $ is_fun expr) && (not $ CoreSyn.isTypeArg expr) = do
+ id <- mkInternalVar "arg" (CoreUtils.exprType expr)
+ change $ Let (Rec [(id, expr)]) (App f (Var id))
+-- Leave all other expressions unchanged
+appsimpl expr = return expr
+-- Perform this transform everywhere
+appsimpltop = everywhere ("appsimpl", appsimpl)
+
+-- TODO: introduce top level let if needed?
+
+--------------------------------
+-- End of transformations
+--------------------------------
+
+
+
+
+-- What transforms to run?
+transforms = [etatop, betatop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinefuntop, appsimpltop]
+
+-- Normalize a core expression by running transforms until none applies
+-- anymore. Uses a UniqSupply to generate new identifiers.
+normalize :: UniqSupply.UniqSupply -> CoreExpr -> CoreExpr
+normalize = dotransforms transforms
+
--- /dev/null
+{-# LANGUAGE PackageImports #-}
+--
+-- This module provides functions for program transformations.
+--
+module NormalizeTools where
+-- Standard modules
+import Debug.Trace
+import qualified List
+import qualified Data.Monoid as Monoid
+import qualified Control.Monad as Monad
+import qualified Control.Monad.Trans.State as State
+import qualified Control.Monad.Trans.Writer as Writer
+import qualified "transformers" Control.Monad.Trans as Trans
+import Data.Accessor
+
+-- GHC API
+import CoreSyn
+import qualified UniqSupply
+import qualified Unique
+import qualified OccName
+import qualified Name
+import qualified Var
+import qualified SrcLoc
+import qualified Type
+import qualified IdInfo
+import qualified CoreUtils
+import qualified CoreSubst
+import Outputable ( showSDoc, ppr, nest )
+
+-- Local imports
+import NormalizeTypes
+
+-- Create a new internal var with the given name and type. A Unique is
+-- appended to the given name, to ensure uniqueness (not strictly neccesary,
+-- since the Unique is also stored in the name, but this ensures variable
+-- names are unique in the output).
+mkInternalVar :: String -> Type.Type -> TransformMonad Var.Var
+mkInternalVar str ty = do
+ uniq <- mkUnique
+ let occname = OccName.mkVarOcc (str ++ show uniq)
+ let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan
+ return $ Var.mkLocalIdVar name ty IdInfo.vanillaIdInfo
+
+-- Apply the given transformation to all expressions in the given expression,
+-- including the expression itself.
+everywhere :: (String, Transform) -> Transform
+everywhere trans = applyboth (subeverywhere (everywhere trans)) trans
+
+-- Apply the first transformation, followed by the second transformation, and
+-- keep applying both for as long as expression still changes.
+applyboth :: Transform -> (String, Transform) -> Transform
+applyboth first (name, second) expr = do
+ -- Apply the first
+ expr' <- first expr
+ -- Apply the second
+ (expr'', changed) <- Writer.listen $ second expr'
+ if Monoid.getAny changed
+ then
+ trace ("Transform " ++ name ++ " changed from:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n" ++ "\nTo:\n" ++ showSDoc (nest 4 $ ppr expr'') ++ "\n" ++ "Type: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr'') ++ "\n" ) $
+ applyboth first (name, second) expr''
+ else
+ return expr''
+
+-- Apply the given transformation to all direct subexpressions (only), not the
+-- expression itself.
+subeverywhere :: Transform -> Transform
+subeverywhere trans (App a b) = do
+ a' <- trans a
+ b' <- trans b
+ return $ App a' b'
+
+subeverywhere trans (Let (Rec binds) expr) = do
+ expr' <- trans expr
+ binds' <- mapM transbind binds
+ return $ Let (Rec binds') expr'
+ where
+ transbind :: (CoreBndr, CoreExpr) -> TransformMonad (CoreBndr, CoreExpr)
+ transbind (b, e) = do
+ e' <- trans e
+ return (b, e')
+
+subeverywhere trans (Lam x expr) = do
+ expr' <- trans expr
+ return $ Lam x expr'
+
+subeverywhere trans (Case scrut b t alts) = do
+ scrut' <- trans scrut
+ alts' <- mapM transalt alts
+ return $ Case scrut' b t alts'
+ where
+ transalt :: CoreAlt -> TransformMonad CoreAlt
+ transalt (con, binders, expr) = do
+ expr' <- trans expr
+ return (con, binders, expr')
+
+
+subeverywhere trans expr = return expr
+
+-- Apply the given transformation to all expressions, except for every first
+-- argument of an application.
+notapplied :: (String, Transform) -> Transform
+notapplied trans = applyboth (subnotapplied trans) trans
+
+-- Apply the given transformation to all (direct and indirect) subexpressions
+-- (but not the expression itself), except for the first argument of an
+-- applicfirst argument of an application
+subnotapplied :: (String, Transform) -> Transform
+subnotapplied trans (App a b) = do
+ a' <- subnotapplied trans a
+ b' <- notapplied trans b
+ return $ App a' b'
+
+-- Let subeverywhere handle all other expressions
+subnotapplied trans expr = subeverywhere (notapplied trans) expr
+
+-- Run the given transforms over the given expression
+dotransforms :: [Transform] -> UniqSupply.UniqSupply -> CoreExpr -> CoreExpr
+dotransforms transs uniqSupply = (flip State.evalState initState) . (dotransforms' transs)
+ where initState = TransformState uniqSupply
+
+-- Runs each of the transforms repeatedly inside the State monad.
+dotransforms' :: [Transform] -> CoreExpr -> State.State TransformState CoreExpr
+dotransforms' transs expr = do
+ (expr', changed) <- Writer.runWriterT $ Monad.foldM (flip ($)) expr transs
+ if Monoid.getAny changed then dotransforms' transs expr' else return expr'
+
+-- Inline all let bindings that satisfy the given condition
+inlinebind :: ((CoreBndr, CoreExpr) -> Bool) -> Transform
+inlinebind condition (Let (Rec binds) expr) | not $ null replace =
+ change newexpr
+ where
+ -- Find all simple bindings
+ (replace, others) = List.partition condition binds
+ -- Substitute the to be replaced binders with their expression
+ newexpr = substitute replace (Let (Rec others) expr)
+-- Leave all other expressions unchanged
+inlinebind _ expr = return expr
+
+-- Sets the changed flag in the TransformMonad, to signify that some
+-- transform has changed the result
+setChanged :: TransformMonad ()
+setChanged = Writer.tell (Monoid.Any True)
+
+-- Sets the changed flag and returns the given value.
+change :: a -> TransformMonad a
+change val = do
+ setChanged
+ return val
+
+-- Create a new Unique
+mkUnique :: TransformMonad Unique.Unique
+mkUnique = Trans.lift $ do
+ us <- getA tsUniqSupply
+ let (us', us'') = UniqSupply.splitUniqSupply us
+ putA tsUniqSupply us'
+ return $ UniqSupply.uniqFromSupply us''
+
+-- Replace each of the binders given with the coresponding expressions in the
+-- given expression.
+substitute :: [(CoreBndr, CoreExpr)] -> CoreExpr -> CoreExpr
+substitute replace expr = CoreSubst.substExpr subs expr
+ where subs = foldl (\s (b, e) -> CoreSubst.extendIdSubst s b e) CoreSubst.emptySubst replace
--- /dev/null
+{-# LANGUAGE TemplateHaskell #-}
+module NormalizeTypes where
+
+
+-- Standard modules
+import qualified Control.Monad.Trans.Writer as Writer
+import qualified Control.Monad.Trans.State as State
+import qualified Data.Monoid as Monoid
+import qualified Data.Accessor.Template
+import Debug.Trace
+
+-- GHC API
+import CoreSyn
+import qualified UniqSupply
+import Outputable ( Outputable, showSDoc, ppr )
+
+-- Local imports
+import CoreShow
+import Pretty
+
+data TransformState = TransformState {
+ tsUniqSupply_ :: UniqSupply.UniqSupply
+}
+
+$( Data.Accessor.Template.deriveAccessors ''TransformState )
+
+type TransformMonad a = Writer.WriterT Monoid.Any (State.State TransformState) a
+-- | Transforms a CoreExpr and keeps track if it has changed.
+type Transform = CoreExpr -> TransformMonad CoreExpr
module Translator where
import qualified Directory
import qualified List
+import Debug.Trace
+import qualified Control.Arrow as Arrow
import GHC hiding (loadModule, sigName)
import CoreSyn
import qualified CoreUtils
import Outputable ( showSDoc, ppr )
import GHC.Paths ( libdir )
import DynFlags ( defaultDynFlags )
+import qualified UniqSupply
import List ( find )
import qualified List
import qualified Monad
import TranslatorTypes
import HsValueMap
import Pretty
+import Normalize
import Flatten
import FlattenTypes
import VHDLTypes
moduleToVHDL :: HscTypes.CoreModule -> [(String, Bool)] -> IO [(AST.VHDLId, AST.DesignFile)]
moduleToVHDL core list = do
let (names, statefuls) = unzip list
- --liftIO $ putStr $ prettyShow (cm_binds core)
let binds = findBinds core names
- --putStr $ prettyShow binds
+ -- Generate a UniqSupply
+ -- Running
+ -- egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
+ -- on the compiler dir of ghc suggests that 'z' is not used to generate a
+ -- unique supply anywhere.
+ uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
-- Turn bind into VHDL
- let (vhdl, sess) = State.runState (mkVHDL binds statefuls) (TranslatorSession core 0 Map.empty)
+ let (vhdl, sess) = State.runState (mkVHDL uniqSupply binds statefuls) (TranslatorSession core 0 Map.empty)
mapM (putStr . render . ForSyDe.Backend.Ppr.ppr . snd) vhdl
putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
return vhdl
where
-- Turns the given bind into VHDL
- mkVHDL :: [(CoreBndr, CoreExpr)] -> [Bool] -> TranslatorState [(AST.VHDLId, AST.DesignFile)]
- mkVHDL binds statefuls = do
+ mkVHDL :: UniqSupply.UniqSupply -> [(CoreBndr, CoreExpr)] -> [Bool] -> TranslatorState [(AST.VHDLId, AST.DesignFile)]
+ mkVHDL uniqSupply binds statefuls = do
+ let binds'' = map (Arrow.second $ normalize uniqSupply) binds
+ let binds' = trace ("Before:\n\n" ++ showSDoc ( ppr binds ) ++ "\n\nAfter:\n\n" ++ showSDoc ( ppr binds'')) binds''
-- Add the builtin functions
--mapM addBuiltIn builtin_funcs
-- Create entities and architectures for them
- Monad.zipWithM processBind statefuls binds
- modA tsFlatFuncs (Map.map nameFlatFunction)
- flatfuncs <- getA tsFlatFuncs
- return $ VHDL.createDesignFiles flatfuncs
+ --Monad.zipWithM processBind statefuls binds
+ --modA tsFlatFuncs (Map.map nameFlatFunction)
+ --flatfuncs <- getA tsFlatFuncs
+ return $ VHDL.createDesignFiles binds'
-- | Write the given design file to a file with the given name inside the
-- given dir
--setTargets [target]
--load LoadAllTargets
--core <- GHC.compileToCoreSimplified "Adders.hs"
- core <- GHC.compileToCoreSimplified filename
+ core <- GHC.compileToCoreModule filename
return core
-- | Extracts the named binds from the given module.
-- Don't do anything if there is already a flat function for this hsfunc or
-- when it is a builtin function.
Monad.unless (Map.member hsfunc flatfuncmap) $ do
- Monad.unless (elem hsfunc VHDL.builtin_hsfuncs) $ do
+ -- Not working with new builtins -- Monad.unless (elem hsfunc VHDL.builtin_hsfuncs) $ do
-- New function, resolve it
core <- getA tsCoreModule
-- Find the named function
import Data.Accessor
import qualified Data.Accessor.MonadState as MonadState
import Text.Regex.Posix
+import Debug.Trace
-- ForSyDe
import qualified ForSyDe.Backend.VHDL.AST as AST
-- GHC API
import qualified Type
import qualified Name
+import qualified OccName
+import qualified Var
import qualified TyCon
+import qualified CoreSyn
import Outputable ( showSDoc, ppr )
-- Local imports
import GlobalNameTable
createDesignFiles ::
- FlatFuncMap
+ [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
-> [(AST.VHDLId, AST.DesignFile)]
-createDesignFiles flatfuncmap =
+createDesignFiles binds =
(mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package]) :
map (Arrow.second $ AST.DesignFile full_context) units
where
init_session = VHDLSession Map.empty Map.empty builtin_funcs globalNameTable
(units, final_session) =
- State.runState (createLibraryUnits flatfuncmap) init_session
+ State.runState (createLibraryUnits binds) init_session
ty_decls = Map.elems (final_session ^. vsTypes)
ieee_context = [
AST.Library $ mkVHDLBasicId "IEEE",
select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
createLibraryUnits ::
- FlatFuncMap
+ [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
-> VHDLState [(AST.VHDLId, [AST.LibraryUnit])]
-createLibraryUnits flatfuncmap = do
- let hsfuncs = Map.keys flatfuncmap
- let flatfuncs = Map.elems flatfuncmap
- entities <- Monad.zipWithM createEntity hsfuncs flatfuncs
- archs <- Monad.zipWithM createArchitecture hsfuncs flatfuncs
+createLibraryUnits binds = do
+ entities <- Monad.mapM createEntity binds
+ archs <- Monad.mapM createArchitecture binds
return $ zipWith
(\ent arch ->
let AST.EntityDec id _ = ent in
-- | Create an entity for a given function
createEntity ::
- HsFunction -- | The function signature
- -> FlatFunction -- | The FlatFunction
+ (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function
-> VHDLState AST.EntityDec -- | The resulting entity
-createEntity hsfunc flatfunc = do
- let sigs = flat_sigs flatfunc
- let args = flat_args flatfunc
- let res = flat_res flatfunc
- args' <- Traversable.traverse (Traversable.traverse (mkMap sigs)) args
- res' <- Traversable.traverse (mkMap sigs) res
- let ent_decl' = createEntityAST hsfunc args' res'
+createEntity (fname, expr) = do
+ -- Strip off lambda's, these will be arguments
+ let (args, letexpr) = CoreSyn.collectBinders expr
+ args' <- Monad.mapM mkMap args
+ -- There must be a let at top level
+ let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
+ res' <- mkMap res
+ let ent_decl' = createEntityAST fname args' res'
let AST.EntityDec entity_id _ = ent_decl'
let signature = Entity entity_id args' res'
- modA vsSignatures (Map.insert hsfunc signature)
+ modA vsSignatures (Map.insert (bndrToString fname) signature)
return ent_decl'
where
mkMap ::
- [(SignalId, SignalInfo)]
- -> SignalId
+ --[(SignalId, SignalInfo)]
+ CoreSyn.CoreBndr
-> VHDLState VHDLSignalMapElement
-- We only need the vsTypes element from the state
- mkMap sigmap = (\id ->
+ mkMap = (\bndr ->
let
- info = Maybe.fromMaybe
- (error $ "Signal not found in the name map? This should not happen!")
- (lookup id sigmap)
- nm = Maybe.fromMaybe
- (error $ "Signal not named? This should not happen!")
- (sigName info)
- ty = sigTy info
+ --info = Maybe.fromMaybe
+ -- (error $ "Signal not found in the name map? This should not happen!")
+ -- (lookup id sigmap)
+ -- Assume the bndr has a valid VHDL id already
+ id = bndrToVHDLId bndr
+ ty = Var.varType bndr
in
- if isPortSigUse $ sigUse info
+ if True -- isPortSigUse $ sigUse info
then do
type_mark <- vhdl_ty ty
- return $ Just (mkVHDLExtId nm, type_mark)
+ return $ Just (id, type_mark)
else
return $ Nothing
)
-- | Create the VHDL AST for an entity
createEntityAST ::
- HsFunction -- | The signature of the function we're working with
- -> [VHDLSignalMap] -- | The entity's arguments
- -> VHDLSignalMap -- | The entity's result
- -> AST.EntityDec -- | The entity with the ent_decl filled in as well
+ CoreSyn.CoreBndr -- | The name of the function
+ -> [VHDLSignalMapElement] -- | The entity's arguments
+ -> VHDLSignalMapElement -- | The entity's result
+ -> AST.EntityDec -- | The entity with the ent_decl filled in as well
-createEntityAST hsfunc args res =
+createEntityAST name args res =
AST.EntityDec vhdl_id ports
where
- vhdl_id = mkEntityId hsfunc
- ports = concatMap (mapToPorts AST.In) args
- ++ mapToPorts AST.Out res
- ++ clk_port
- mapToPorts :: AST.Mode -> VHDLSignalMap -> [AST.IfaceSigDec]
- mapToPorts mode m =
- Maybe.catMaybes $ map (mkIfaceSigDec mode) (Foldable.toList m)
+ -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
+ vhdl_id = mkVHDLBasicId $ bndrToString name
+ ports = Maybe.catMaybes $
+ map (mkIfaceSigDec AST.In) args
+ ++ [mkIfaceSigDec AST.Out res]
+ ++ [clk_port]
-- Add a clk port if we have state
- clk_port = if hasState hsfunc
+ clk_port = if True -- hasState hsfunc
then
- [AST.IfaceSigDec (mkVHDLExtId "clk") AST.In VHDL.std_logic_ty]
+ Just $ AST.IfaceSigDec (mkVHDLExtId "clk") AST.In VHDL.std_logic_ty
else
- []
+ Nothing
-- | Create a port declaration
mkIfaceSigDec ::
-- | Create an architecture for a given function
createArchitecture ::
- HsFunction -- ^ The function signature
- -> FlatFunction -- ^ The FlatFunction
+ (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
-> VHDLState AST.ArchBody -- ^ The architecture for this function
-createArchitecture hsfunc flatfunc = do
- signaturemap <- getA vsSignatures
- let signature = Maybe.fromMaybe
- (error $ "Generating architecture for function " ++ (prettyShow hsfunc) ++ "without signature? This should not happen!")
- (Map.lookup hsfunc signaturemap)
- let entity_id = ent_id signature
+createArchitecture (fname, expr) = do
+ --signaturemap <- getA vsSignatures
+ --let signature = Maybe.fromMaybe
+ -- (error $ "Generating architecture for function " ++ (prettyShow hsfunc) ++ "without signature? This should not happen!")
+ -- (Map.lookup hsfunc signaturemap)
+ let entity_id = mkVHDLBasicId $ bndrToString fname
+ -- Strip off lambda's, these will be arguments
+ let (args, letexpr) = CoreSyn.collectBinders expr
+ -- There must be a let at top level
+ let (CoreSyn.Let (CoreSyn.Rec binds) res) = letexpr
+
-- Create signal declarations for all internal and state signals
- sig_dec_maybes <- mapM (mkSigDec' . snd) sigs
+ sig_dec_maybes <- mapM (mkSigDec' . fst) binds
let sig_decs = Maybe.catMaybes $ sig_dec_maybes
- -- Create concurrent statements for all signal definitions
- statements <- Monad.zipWithM (mkConcSm sigs) defs [0..]
+
+ statements <- Monad.mapM mkConcSm binds
return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
where
- sigs = flat_sigs flatfunc
- args = flat_args flatfunc
- res = flat_res flatfunc
- defs = flat_defs flatfunc
- procs = map mkStateProcSm (makeStatePairs flatfunc)
+ procs = map mkStateProcSm [] -- (makeStatePairs flatfunc)
procs' = map AST.CSPSm procs
-- mkSigDec only uses vsTypes from the state
mkSigDec' = mkSigDec
rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
statement = AST.IfSm rising_edge_clk [assign] [] Nothing
-mkSigDec :: SignalInfo -> VHDLState (Maybe AST.SigDec)
-mkSigDec info =
- let use = sigUse info in
- if isInternalSigUse use || isStateSigUse use then do
- type_mark <- vhdl_ty ty
- return $ Just (AST.SigDec (getSignalId info) type_mark Nothing)
+mkSigDec :: CoreSyn.CoreBndr -> VHDLState (Maybe AST.SigDec)
+mkSigDec bndr =
+ if True then do --isInternalSigUse use || isStateSigUse use then do
+ type_mark <- vhdl_ty $ Var.varType bndr
+ return $ Just (AST.SigDec (bndrToVHDLId bndr) type_mark Nothing)
else
return Nothing
- where
- ty = sigTy info
-- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
-- is not named.
(error $ "Unnamed signal? This should not happen!")
(sigName info)
--- | Transforms a signal definition into a VHDL concurrent statement
+-- | Transforms a core binding into a VHDL concurrent statement
mkConcSm ::
- [(SignalId, SignalInfo)] -- ^ The signals in the current architecture
- -> SigDef -- ^ The signal definition
- -> Int -- ^ A number that will be unique for all
- -- concurrent statements in the architecture.
+ (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
-> VHDLState AST.ConcSm -- ^ The corresponding VHDL component instantiation.
-mkConcSm sigs (FApp hsfunc args res) num = do
+mkConcSm (bndr, app@(CoreSyn.App _ _))= do
signatures <- getA vsSignatures
let
+ (CoreSyn.Var f, args) = CoreSyn.collectArgs app
signature = Maybe.fromMaybe
- (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without signature? This should not happen!")
- (Map.lookup hsfunc signatures)
+ (error $ "Using function '" ++ (bndrToString f) ++ "' without signature? This should not happen!")
+ (Map.lookup (bndrToString f) signatures)
entity_id = ent_id signature
- label = (AST.fromVHDLId entity_id) ++ "_" ++ (show num)
+ label = bndrToString bndr
-- Add a clk port if we have state
- clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
- portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
+ --clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
+ --portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
+ portmaps = mkAssocElems args bndr signature
in
return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
+-- GHC generates some funny "r = r" bindings in let statements before
+-- simplification. This outputs some dummy ConcSM for these, so things will at
+-- least compile for now.
+mkConcSm (bndr, CoreSyn.Var _) = return $ AST.CSPSm $ AST.ProcSm (mkVHDLBasicId "unused") [] []
+
+{-
mkConcSm sigs (UncondDef src dst) _ = do
src_expr <- vhdl_expr src
let src_wform = AST.Wform [AST.WformElem src_expr Nothing]
assign = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
in
return $ AST.CSSASm assign
-
+-}
-- | Turn a SignalId into a VHDL Expr
mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
mkIdExpr sigs id =
AST.PrimName src_name
mkAssocElems ::
- [(SignalId, SignalInfo)] -- | The signals in the current architecture
- -> [SignalMap] -- | The signals that are applied to function
- -> SignalMap -- | the signals in which to store the function result
+ [CoreSyn.CoreExpr] -- | The argument that are applied to function
+ -> CoreSyn.CoreBndr -- | The binder in which to store the result
-> Entity -- | The entity to map against.
-> [AST.AssocElem] -- | The resulting port maps
-mkAssocElems sigmap args res entity =
+mkAssocElems args res entity =
-- Create the actual AssocElems
Maybe.catMaybes $ zipWith mkAssocElem ports sigs
where
-- Turn the ports and signals from a map into a flat list. This works,
-- since the maps must have an identical form by definition. TODO: Check
-- the similar form?
- arg_ports = concat (map Foldable.toList (ent_args entity))
- res_ports = Foldable.toList (ent_res entity)
- arg_sigs = (concat (map Foldable.toList args))
- res_sigs = Foldable.toList res
+ arg_ports = ent_args entity
+ res_port = ent_res entity
-- Extract the id part from the (id, type) tuple
- ports = (map (fmap fst) (arg_ports ++ res_ports))
+ ports = map (Monad.liftM fst) (res_port : arg_ports)
-- Translate signal numbers into names
- sigs = (map (lookupSigName sigmap) (arg_sigs ++ res_sigs))
+ sigs = (bndrToString res : map (bndrToString.varBndr) args)
+
+-- Turns a Var CoreExpr into the Id inside it. Will of course only work for
+-- simple Var CoreExprs, not complexer ones.
+varBndr :: CoreSyn.CoreExpr -> Var.Id
+varBndr (CoreSyn.Var id) = id
-- | Look up a signal in the signal name map
lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
strip_invalid = filter (`elem` allowed)
+-- Creates a VHDL Id from a binder
+bndrToVHDLId ::
+ CoreSyn.CoreBndr
+ -> AST.VHDLId
+
+bndrToVHDLId = mkVHDLExtId . OccName.occNameString . Name.nameOccName . Var.varName
+
+-- Extracts the binder name as a String
+bndrToString ::
+ CoreSyn.CoreBndr
+ -> String
+
+bndrToString = OccName.occNameString . Name.nameOccName . Var.varName
+
-- | A consise representation of a (set of) ports on a builtin function
-type PortMap = HsValueMap (String, AST.TypeMark)
+--type PortMap = HsValueMap (String, AST.TypeMark)
-- | A consise representation of a builtin function
-data BuiltIn = BuiltIn String [PortMap] PortMap
+data BuiltIn = BuiltIn String [(String, AST.TypeMark)] (String, AST.TypeMark)
-- | Translate a list of concise representation of builtin functions to a
-- SignatureMap
mkBuiltins :: [BuiltIn] -> SignatureMap
mkBuiltins = Map.fromList . map (\(BuiltIn name args res) ->
- (HsFunction name (map useAsPort args) (useAsPort res),
- Entity (VHDL.mkVHDLBasicId name) (map toVHDLSignalMap args) (toVHDLSignalMap res))
+ (name,
+ Entity (VHDL.mkVHDLBasicId name) (map toVHDLSignalMapElement args) (toVHDLSignalMapElement res))
)
builtin_hsfuncs = Map.keys builtin_funcs
builtin_funcs = mkBuiltins
[
- BuiltIn "hwxor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
- BuiltIn "hwand" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
- BuiltIn "hwor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
- BuiltIn "hwnot" [(Single ("a", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty))
+ BuiltIn "hwxor" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
+ BuiltIn "hwand" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
+ BuiltIn "hwor" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
+ BuiltIn "hwnot" [("a", VHDL.bit_ty)] ("o", VHDL.bit_ty)
]
-- | Map a port specification of a builtin function to a VHDL Signal to put in
-- a VHDLSignalMap
-toVHDLSignalMap :: HsValueMap (String, AST.TypeMark) -> VHDLSignalMap
-toVHDLSignalMap = fmap (\(name, ty) -> Just (mkVHDLBasicId name, ty))
+toVHDLSignalMapElement :: (String, AST.TypeMark) -> VHDLSignalMapElement
+toVHDLSignalMapElement (name, ty) = Just (mkVHDLBasicId name, ty)
-- GHC API imports
import qualified Type
+import qualified CoreSyn
-- ForSyDe imports
import qualified ForSyDe.Backend.VHDL.AST as AST
-- ports.
data Entity = Entity {
ent_id :: AST.VHDLId, -- The id of the entity
- ent_args :: [VHDLSignalMap], -- A mapping of each function argument to port names
- ent_res :: VHDLSignalMap -- A mapping of the function result to port names
+ ent_args :: [VHDLSignalMapElement], -- A mapping of each function argument to port names
+ ent_res :: VHDLSignalMapElement -- A mapping of the function result to port names
} deriving (Show);
-- A orderable equivalent of CoreSyn's Type for use as a map key
type TypeFunMap = Map.Map OrdType [AST.SubProgBody]
-- A map of a Haskell function to a hardware signature
-type SignatureMap = Map.Map HsFunction Entity
+type SignatureMap = Map.Map String Entity
-- A map of a builtin function to VHDL function builder
type NameTable = Map.Map String (Int, [AST.Expr] -> AST.Expr )
projects / matthijs / master-project / cλash.git / commitdiff