From: Matthijs Kooijman Date: Thu, 25 Jun 2009 09:12:07 +0000 (+0200) Subject: Unify all BuiltinBuilder functions. X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=0c113a538aa9a891935665481782bdce8350e345;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git Unify all BuiltinBuilder functions. By create a few wrapper functions, we can still leave the functions mostly unchanged, but register them all with the same interface in the GlobalNameTable. --- diff --git a/Generate.hs b/Generate.hs index 5151978..7de2161 100644 --- a/Generate.hs +++ b/Generate.hs @@ -5,6 +5,7 @@ import qualified Control.Monad as Monad import qualified Data.Map as Map import qualified Maybe import Data.Accessor +import Debug.Trace -- ForSyDe import qualified ForSyDe.Backend.VHDL.AST as AST @@ -19,32 +20,67 @@ import Constants import VHDLTypes import VHDLTools import CoreTools +import Pretty + +-- | A function to wrap a builder-like function that expects its arguments to +-- be expressions. +genExprArgs :: + (dst -> func -> [AST.Expr] -> res) + -> (dst -> func -> [CoreSyn.CoreExpr] -> res) +genExprArgs wrap dst func args = wrap dst func args' + where args' = map (varToVHDLExpr.exprToVar) args + +-- | A function to wrap a builder-like function that expects its arguments to +-- be variables. +genVarArgs :: + (dst -> func -> [Var.Var] -> res) + -> (dst -> func -> [CoreSyn.CoreExpr] -> res) +genVarArgs wrap dst func args = wrap dst func args' + where args' = map exprToVar args + +-- | A function to wrap a builder-like function that produces an expression +-- and expects it to be assigned to the destination. +genExprRes :: + (CoreSyn.CoreBndr -> func -> [arg] -> VHDLSession AST.Expr) + -> (CoreSyn.CoreBndr -> func -> [arg] -> VHDLSession [AST.ConcSm]) +genExprRes wrap dst func args = do + expr <- wrap dst func args + return $ [mkUncondAssign (Left dst) expr] -- | Generate a binary operator application. The first argument should be a -- constructor from the AST.Expr type, e.g. AST.And. -genExprOp2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr -genExprOp2 op res [arg1, arg2] = return $ op arg1 arg2 +genOperator2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> BuiltinBuilder +genOperator2 op = genExprArgs $ genExprRes (genOperator2' op) +genOperator2' :: (AST.Expr -> AST.Expr -> AST.Expr) -> CoreSyn.CoreBndr -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr +genOperator2' op res f [arg1, arg2] = return $ op arg1 arg2 -- | Generate a unary operator application -genExprOp1 :: (AST.Expr -> AST.Expr) -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr -genExprOp1 op res [arg] = return $ op arg +genOperator1 :: (AST.Expr -> AST.Expr) -> BuiltinBuilder +genOperator1 op = genExprArgs $ genExprRes (genOperator1' op) +genOperator1' :: (AST.Expr -> AST.Expr) -> CoreSyn.CoreBndr -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr +genOperator1' op res f [arg] = return $ op arg -- | Generate a function call from the destination binder, function name and a -- list of expressions (its arguments) -genExprFCall :: String -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr -genExprFCall fname res args = do +genFCall :: BuiltinBuilder +genFCall = genExprArgs $ genExprRes genFCall' +genFCall' :: CoreSyn.CoreBndr -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr +genFCall' res f args = do + let fname = varToString f let el_ty = (tfvec_elem . Var.varType) res id <- vectorFunId el_ty fname return $ AST.PrimFCall $ AST.FCall (AST.NSimple id) $ map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args -- | Generate a generate statement for the builtin function "map" -genMapCall :: - Entity -- | The entity to map - -> [CoreSyn.CoreBndr] -- | The vectors - -> VHDLSession AST.ConcSm -- | The resulting generate statement -genMapCall entity [arg, res] = return $ genSm - where +genMap :: BuiltinBuilder +genMap = genVarArgs genMap' +genMap' res f [mapped_f, arg] = do + signatures <- getA vsSignatures + let entity = Maybe.fromMaybe + (error $ "Using function '" ++ (varToString mapped_f) ++ "' without signature? This should not happen!") + (Map.lookup mapped_f signatures) + let -- Setup the generate scheme len = (tfvec_len . Var.varType) res label = mkVHDLExtId ("mapVector" ++ (varToString res)) @@ -65,13 +101,17 @@ genMapCall entity [arg, res] = return $ genSm compins = mkComponentInst mapLabel entity_id portassigns -- Return the generate functions genSm = AST.CSGSm $ AST.GenerateSm label genScheme [] [compins] + in + return $ [genSm] -genZipWithCall :: - Entity - -> [CoreSyn.CoreBndr] - -> VHDLSession AST.ConcSm -genZipWithCall entity [arg1, arg2, res] = return $ genSm - where +genZipWith :: BuiltinBuilder +genZipWith = genVarArgs genZipWith' +genZipWith' res f args@[zipped_f, arg1, arg2] = do + signatures <- getA vsSignatures + let entity = Maybe.fromMaybe + (error $ "Using function '" ++ (varToString zipped_f) ++ "' without signature? This should not happen!") + (Map.lookup zipped_f signatures) + let -- Setup the generate scheme len = (tfvec_len . Var.varType) res label = mkVHDLExtId ("zipWithVector" ++ (varToString res)) @@ -93,12 +133,16 @@ genZipWithCall entity [arg1, arg2, res] = return $ genSm compins = mkComponentInst mapLabel entity_id portassigns -- Return the generate functions genSm = AST.CSGSm $ AST.GenerateSm label genScheme [] [compins] + in + return $ [genSm] -genFoldlCall :: - Entity - -> [CoreSyn.CoreBndr] - -> VHDLSession AST.ConcSm -genFoldlCall entity [startVal, inVec, resVal] = do +genFoldl :: BuiltinBuilder +genFoldl = genVarArgs genFoldl' +genFoldl' resVal f [folded_f, startVal, inVec] = do + signatures <- getA vsSignatures + let entity = Maybe.fromMaybe + (error $ "Using function '" ++ (varToString folded_f) ++ "' without signature? This should not happen!") + (Map.lookup folded_f signatures) let (vec, _) = splitAppTy (Var.varType inVec) let vecty = Type.mkAppTy vec (Var.varType startVal) vecType <- vhdl_ty vecty @@ -116,7 +160,7 @@ genFoldlCall entity [startVal, inVec, resVal] = do , AST.CSGSm (genOtherCell entity [startVal, inVec, resVal]) , AST.CSGSm (genLastCell entity [startVal, inVec, resVal]) ] - return $ AST.CSBSm $ AST.BlockSm blockLabel [] (AST.PMapAspect []) [tmpVec] [AST.CSGSm genSm] + return [AST.CSBSm $ AST.BlockSm blockLabel [] (AST.PMapAspect []) [tmpVec] [AST.CSGSm genSm]] where genFirstCell :: Entity -> [CoreSyn.CoreBndr] -> AST.GenerateSm genFirstCell entity [startVal, inVec, resVal] = cellGn diff --git a/GlobalNameTable.hs b/GlobalNameTable.hs index 9a61227..ab56574 100644 --- a/GlobalNameTable.hs +++ b/GlobalNameTable.hs @@ -12,28 +12,28 @@ import VHDLTypes import Constants import Generate -mkGlobalNameTable :: [(String, (Int, Builder) )] -> NameTable +mkGlobalNameTable :: [(String, (Int, BuiltinBuilder) )] -> NameTable mkGlobalNameTable = Map.fromList globalNameTable :: NameTable globalNameTable = mkGlobalNameTable - [ (exId , (2, Left $ genExprFCall exId ) ) - , (replaceId , (3, Left $ genExprFCall replaceId ) ) - , (headId , (1, Left $ genExprFCall headId ) ) - , (lastId , (1, Left $ genExprFCall lastId ) ) - , (tailId , (1, Left $ genExprFCall tailId ) ) - , (initId , (1, Left $ genExprFCall initId ) ) - , (takeId , (2, Left $ genExprFCall takeId ) ) - , (dropId , (2, Left $ genExprFCall dropId ) ) - , (plusgtId , (2, Left $ genExprFCall plusgtId ) ) - , (mapId , (2, Right $ genMapCall ) ) - , (zipWithId , (3, Right $ genZipWithCall ) ) - , (foldlId , (3, Right $ genFoldlCall ) ) - , (emptyId , (0, Left $ genExprFCall emptyId ) ) - , (singletonId , (1, Left $ genExprFCall singletonId ) ) - , (copyId , (2, Left $ genExprFCall copyId ) ) - , (hwxorId , (2, Left $ genExprOp2 AST.Xor ) ) - , (hwandId , (2, Left $ genExprOp2 AST.And ) ) - , (hworId , (2, Left $ genExprOp2 AST.Or ) ) - , (hwnotId , (1, Left $ genExprOp1 AST.Not ) ) + [ (exId , (2, genFCall ) ) + , (replaceId , (3, genFCall ) ) + , (headId , (1, genFCall ) ) + , (lastId , (1, genFCall ) ) + , (tailId , (1, genFCall ) ) + , (initId , (1, genFCall ) ) + , (takeId , (2, genFCall ) ) + , (dropId , (2, genFCall ) ) + , (plusgtId , (2, genFCall ) ) + , (mapId , (2, genMap ) ) + , (zipWithId , (3, genZipWith ) ) + , (foldlId , (3, genFoldl ) ) + , (emptyId , (0, genFCall ) ) + , (singletonId , (1, genFCall ) ) + , (copyId , (2, genFCall ) ) + , (hwxorId , (2, genOperator2 AST.Xor ) ) + , (hwandId , (2, genOperator2 AST.And ) ) + , (hworId , (2, genOperator2 AST.Or ) ) + , (hwnotId , (1, genOperator1 AST.Not ) ) ] diff --git a/VHDL.hs b/VHDL.hs index 3bd2fe2..920b83e 100644 --- a/VHDL.hs +++ b/VHDL.hs @@ -12,6 +12,7 @@ import qualified Control.Arrow as Arrow import qualified Control.Monad.Trans.State as State import qualified Data.Monoid as Monoid import Data.Accessor +import Debug.Trace -- ForSyDe import qualified ForSyDe.Backend.VHDL.AST as AST @@ -298,22 +299,7 @@ mkConcSm (bndr, app@(CoreSyn.App _ _))= do case (Map.lookup (varToString f) globalNameTable) of Just (arg_count, builder) -> if length valargs == arg_count then - case builder of - Left funBuilder -> do - let sigs = map (varToVHDLExpr.exprToVar) valargs - func <- funBuilder bndr sigs - let src_wform = AST.Wform [AST.WformElem func Nothing] - let dst_name = AST.NSimple (mkVHDLExtId (varToString bndr)) - let assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing) - return [AST.CSSASm assign] - Right genBuilder -> do - let sigs = map exprToVar valargs - let signature = Maybe.fromMaybe - (error $ "Using function '" ++ (varToString (head sigs)) ++ "' without signature? This should not happen!") - (Map.lookup (head sigs) signatures) - let arg = tail sigs - genSm <- genBuilder signature (arg ++ [bndr]) - return [genSm] + builder bndr f valargs else error $ "VHDL.mkConcSm Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ pprString valargs Nothing -> error $ "Using function from another module that is not a known builtin: " ++ pprString f diff --git a/VHDLTypes.hs b/VHDLTypes.hs index a533bf5..79d7675 100644 --- a/VHDLTypes.hs +++ b/VHDLTypes.hs @@ -76,9 +76,15 @@ type VHDLSession = State.State VHDLState -- | A substate containing just the types type TypeState = State.State TypeMap -type Builder = Either (CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr) (Entity -> [CoreSyn.CoreBndr] -> VHDLSession AST.ConcSm) +-- A function that generates VHDL for a builtin function +type BuiltinBuilder = + CoreSyn.CoreBndr -- ^ The destination value + -> CoreSyn.CoreBndr -- ^ The function called + -> [CoreSyn.CoreExpr] -- ^ The value arguments passed (excluding type and + -- dictionary arguments). + -> VHDLSession [AST.ConcSm] -- ^ The resulting concurrent statements. -- A map of a builtin function to VHDL function builder -type NameTable = Map.Map String (Int, Builder ) +type NameTable = Map.Map String (Int, BuiltinBuilder ) -- vim: set ts=8 sw=2 sts=2 expandtab: