From: Christiaan Baaij Date: Fri, 19 Jun 2009 10:17:44 +0000 (+0200) Subject: Merge branch 'cλash' of http://git.stderr.nl/matthijs/projects/master-project X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=e230d86ae7135a268a72cdffba947a9011001ec2;hp=c5bde4d7862c7df2b4bad183088f77a43d8b5a2c;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git Merge branch 'cλash' of git.stderr.nl/matthijs/projects/master-project * 'cλash' of http://git.stderr.nl/matthijs/projects/master-project: Use highordtest in main, since that can now be normalized. Add a (fairly complete) set of transforms. Add is_lam and is_fun predicates. Add a inlinebind helper function. Add a substitute helper function. Print the type in the transform debug output. Add infrastructure for running core to core transformations. Add a higher order testcase. Add is_wild function to check for wild binders. Generate VHDL from Core instead of flat functions. Conflicts: Translator.hs VHDL.hs --- diff --git a/Adders.hs b/Adders.hs index e6676e9..2ee1de6 100644 --- a/Adders.hs +++ b/Adders.hs @@ -53,7 +53,7 @@ instance Inv (BitVec D0) where -} -- 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 @@ -146,6 +146,25 @@ rec_adder ((a:as), (b:bs)) = (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 = diff --git a/CoreTools.hs b/CoreTools.hs index 5fbe871..a8dce3f 100644 --- a/CoreTools.hs +++ b/CoreTools.hs @@ -11,11 +11,16 @@ import qualified HsExpr 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 @@ -77,3 +82,20 @@ tfvec_len ty = 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 diff --git a/Main.hs b/Main.hs index be0a0a0..be48aa3 100644 --- a/Main.hs +++ b/Main.hs @@ -3,4 +3,4 @@ module Main where 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 diff --git a/Normalize.hs b/Normalize.hs new file mode 100644 index 0000000..2b37e09 --- /dev/null +++ b/Normalize.hs @@ -0,0 +1,291 @@ +-- +-- 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 + diff --git a/NormalizeTools.hs b/NormalizeTools.hs new file mode 100644 index 0000000..6699101 --- /dev/null +++ b/NormalizeTools.hs @@ -0,0 +1,162 @@ +{-# 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 diff --git a/NormalizeTypes.hs b/NormalizeTypes.hs new file mode 100644 index 0000000..e61570a --- /dev/null +++ b/NormalizeTypes.hs @@ -0,0 +1,29 @@ +{-# 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 diff --git a/Translator.hs b/Translator.hs index f377152..0f60277 100644 --- a/Translator.hs +++ b/Translator.hs @@ -1,6 +1,8 @@ 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 @@ -26,6 +28,7 @@ import MonadUtils ( liftIO ) import Outputable ( showSDoc, ppr ) import GHC.Paths ( libdir ) import DynFlags ( defaultDynFlags ) +import qualified UniqSupply import List ( find ) import qualified List import qualified Monad @@ -43,6 +46,7 @@ import Text.PrettyPrint.HughesPJ (render) import TranslatorTypes import HsValueMap import Pretty +import Normalize import Flatten import FlattenTypes import VHDLTypes @@ -81,25 +85,31 @@ listBind filename name = do 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 @@ -126,7 +136,7 @@ loadModule filename = --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. @@ -270,7 +280,7 @@ resolvFunc hsfunc = do -- 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 diff --git a/VHDL.hs b/VHDL.hs index 846cd81..d177a10 100644 --- a/VHDL.hs +++ b/VHDL.hs @@ -16,6 +16,7 @@ import qualified Data.Monoid as Monoid 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 @@ -23,7 +24,10 @@ 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 @@ -39,17 +43,17 @@ import Generate 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", @@ -72,14 +76,12 @@ mkUseAll ss = 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 @@ -89,68 +91,66 @@ createLibraryUnits flatfuncmap = do -- | 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 :: @@ -170,28 +170,28 @@ mkEntityId hsfunc = -- | 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 @@ -223,16 +223,13 @@ mkStateProcSm (num, old, new) = 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. @@ -242,28 +239,33 @@ getSignalId info = (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] @@ -301,7 +303,7 @@ mkConcSm sigs (CondDef cond true false dst) _ = 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 = @@ -309,27 +311,29 @@ 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 @@ -445,29 +449,43 @@ mkVHDLExtId s = 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) diff --git a/VHDLTypes.hs b/VHDLTypes.hs index f317167..e517a8b 100644 --- a/VHDLTypes.hs +++ b/VHDLTypes.hs @@ -12,6 +12,7 @@ import qualified Data.Accessor.Template -- GHC API imports import qualified Type +import qualified CoreSyn -- ForSyDe imports import qualified ForSyDe.Backend.VHDL.AST as AST @@ -30,8 +31,8 @@ type VHDLSignalMap = HsValueMap VHDLSignalMapElement -- 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 @@ -48,7 +49,7 @@ type TypeMap = Map.Map OrdType (AST.VHDLId, AST.TypeDec) 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 )