From: Christiaan Baaij Date: Thu, 25 Jun 2009 09:16:27 +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=ede1f399f096569d1305cd75cb21f037bd4162dc;hp=a44db062ae75b4fe3ce28368e07323130a14fe58;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: Unify all BuiltinBuilder functions. Give HighOrdAlu an and operation. Let tfvec_len and tfvec_elem give a proper error message. No longer use a view pattern in HsTools. Conflicts: Generate.hs --- diff --git a/CoreTools.hs b/CoreTools.hs index b08f3ce..c797bb7 100644 --- a/CoreTools.hs +++ b/CoreTools.hs @@ -27,8 +27,10 @@ import qualified Unique import qualified CoreUtils import qualified CoreFVs +-- Local imports import GhcTools import HsTools +import Pretty -- | Evaluate a core Type representing type level int from the tfp -- library to a real int. @@ -92,15 +94,19 @@ ranged_word_bound ty = tfvec_len :: Type.Type -> Int tfvec_len ty = eval_tfp_int len - where - (tycon, args) = Type.splitTyConApp ty + where + args = case Type.splitTyConApp_maybe ty of + Just (tycon, args) -> args + Nothing -> error $ "CoreTools.tfvec_len Not a vector type: " ++ (pprString ty) [len, el_ty] = args -- | Get the element type of a TFVec type tfvec_elem :: Type.Type -> Type.Type tfvec_elem ty = el_ty where - (tycon, args) = Type.splitTyConApp ty + args = case Type.splitTyConApp_maybe ty of + Just (tycon, args) -> args + Nothing -> error $ "CoreTools.tfvec_len Not a vector type: " ++ (pprString ty) [len, el_ty] = args -- Is this a wild binder? diff --git a/Generate.hs b/Generate.hs index 17c3d49..7b8dcf0 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)) @@ -64,13 +100,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)) @@ -91,12 +131,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 @@ -112,7 +156,7 @@ genFoldlCall entity [startVal, inVec, resVal] = do let entity_id = ent_id entity let argports = map (Monad.liftM fst) (ent_args entity) let resport = (Monad.liftM fst) (ent_res entity) - -- Return the generate functions + -- Return the generate functions let genSm = AST.GenerateSm genlabel genScheme [] [ AST.CSGSm (genFirstCell (entity_id, argports, resport) [startVal, inVec, resVal]) @@ -121,7 +165,7 @@ genFoldlCall entity [startVal, inVec, resVal] = do , AST.CSGSm (genLastCell (entity_id, argports, resport) [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_id, argports, resport) [startVal, inVec, resVal] = cellGn where 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/HighOrdAlu.hs b/HighOrdAlu.hs index cdef771..6458f3c 100644 --- a/HighOrdAlu.hs +++ b/HighOrdAlu.hs @@ -10,13 +10,18 @@ import Data.RangedWord constant :: e -> Op D4 e constant e a b = - e +> (e +> (e +> (e +> empty))) + e +> (e +> (e +> (singleton e ))) inv = hwnot invop :: Op n Bit invop a b = map inv a +xand = hwand + +andop :: Op n Bit +andop a b = zipWith xand a b + type Op n e = (TFVec n e -> TFVec n e -> TFVec n e) type Opcode = Bit @@ -26,5 +31,5 @@ alu op1 op2 opc a b = Low -> op1 a b High -> op2 a b -zero_inv_alu :: Opcode -> TFVec D4 Bit -> TFVec D4 Bit -> TFVec D4 Bit -zero_inv_alu = alu (constant Low) invop +actual_alu :: Opcode -> TFVec D4 Bit -> TFVec D4 Bit -> TFVec D4 Bit +actual_alu = alu (constant Low) andop diff --git a/HsTools.hs b/HsTools.hs index 967db18..0f3e463 100644 --- a/HsTools.hs +++ b/HsTools.hs @@ -126,14 +126,16 @@ mkId rdr_name = do -- | Translate a core Type to an HsType. Far from complete so far. coreToHsType :: Type.Type -> HsTypes.LHsType RdrName.RdrName -- Translate TyConApps -coreToHsType (Type.splitTyConApp_maybe -> Just (tycon, tys)) = - foldl (\t a -> SrcLoc.noLoc $ HsTypes.HsAppTy t a) tycon_ty (map coreToHsType tys) - where - tycon_name = TyCon.tyConName tycon - mod_name = Module.moduleName $ Name.nameModule tycon_name - occ_name = Name.nameOccName tycon_name - tycon_rdrname = RdrName.mkRdrQual mod_name occ_name - tycon_ty = SrcLoc.noLoc $ HsTypes.HsTyVar tycon_rdrname +coreToHsType ty = case Type.splitTyConApp_maybe ty of + Just (tycon, tys) -> + foldl (\t a -> SrcLoc.noLoc $ HsTypes.HsAppTy t a) tycon_ty (map coreToHsType tys) + where + tycon_name = TyCon.tyConName tycon + mod_name = Module.moduleName $ Name.nameModule tycon_name + occ_name = Name.nameOccName tycon_name + tycon_rdrname = RdrName.mkRdrQual mod_name occ_name + tycon_ty = SrcLoc.noLoc $ HsTypes.HsTyVar tycon_rdrname + Nothing -> error $ "HsTools.coreToHsType Cannot translate non-tycon type" -- | Evaluate a CoreExpr and return its value. For this to work, the caller -- should already know the result type for sure, since the result value is diff --git a/VHDL.hs b/VHDL.hs index 998efb4..4b69df5 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: