From 04de89474351850ea9dca0350fa383f1b2aff8ea Mon Sep 17 00:00:00 2001 From: Christiaan Baaij Date: Fri, 31 Jul 2009 09:19:57 +0200 Subject: [PATCH] Quick hack implementation of FSVec literals, needs to be fixed --- Bits.hs | 24 +++++----- HighOrdAlu.hs | 40 +++++++++------- "c\316\273ash/CLasH/Normalize.hs" | 7 +-- "c\316\273ash/CLasH/Utils/Core/CoreTools.hs" | 2 +- "c\316\273ash/CLasH/VHDL.hs" | 9 ---- "c\316\273ash/CLasH/VHDL/Constants.hs" | 6 +++ "c\316\273ash/CLasH/VHDL/Generate.hs" | 48 +++++++++++++++++++- "c\316\273ash/CLasH/VHDL/VHDLTools.hs" | 32 +++++++++++-- 8 files changed, 124 insertions(+), 44 deletions(-) diff --git a/Bits.hs b/Bits.hs index 435b04e..558a12b 100644 --- a/Bits.hs +++ b/Bits.hs @@ -1,11 +1,13 @@ -{-# LANGUAGE FlexibleContexts,GADTs,ExistentialQuantification,LiberalTypeSynonyms,TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts,GADTs,ExistentialQuantification,LiberalTypeSynonyms,TemplateHaskell, DeriveDataTypeable #-} module Bits where -import qualified Data.Param.TFVec as TFVec -import qualified Types +-- import qualified Data.Param.TFVec as TFVec +-- import qualified Types import Language.Haskell.TH.Lift +import Data.Typeable + --class Signal a where -- hwand :: a -> a -> a -- hwor :: a -> a -> a @@ -45,22 +47,22 @@ displaysig Low = "0" -- The plain Bit type data Bit = High | Low - deriving (Show, Eq, Read) + deriving (Show, Eq, Read, Typeable) $(deriveLift1 ''Bit) -- A function to prettyprint a bitvector --displaysigs :: (Signal s) => [s] -> String -displaysigs :: [Bit] -> String -displaysigs = (foldl (++) "") . (map displaysig) +-- displaysigs :: [Bit] -> String +-- displaysigs = (foldl (++) "") . (map displaysig) -type Stream a = [a] +-- type Stream a = [a] -- An infinite streams of highs or lows -lows = Low : lows -highs = High : highs - -type BitVec len = TFVec.TFVec len Bit +-- lows = Low : lows +-- highs = High : highs +-- +-- type BitVec len = TFVec.TFVec len Bit -- vim: set ts=8 sw=2 sts=2 expandtab: diff --git a/HighOrdAlu.hs b/HighOrdAlu.hs index 1ead210..6b11350 100644 --- a/HighOrdAlu.hs +++ b/HighOrdAlu.hs @@ -1,34 +1,39 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-} module HighOrdAlu where +import qualified Prelude as P import Prelude hiding ( null, length, head, tail, last, init, take, drop, (++), map, foldl, foldr, zipWith, zip, unzip, concat, reverse, iterate ) import Bits -import Types +-- import Types +import Types.Data.Num.Ops +import Types.Data.Num.Decimal.Digits +import Types.Data.Num.Decimal.Ops +import Types.Data.Num.Decimal.Literals import Data.Param.TFVec import Data.RangedWord +import Data.SizedInt import CLasH.Translator.Annotations -constant :: e -> Op D4 e -constant e a b = - (e +> (e +> (e +> (singleton e)))) +constant :: NaturalT n => e -> Op n e +constant e a b = copy e invop :: Op n Bit invop a b = map hwnot a -andop :: Op n Bit -andop a b = zipWith hwand a b +andop :: (e -> e -> e) -> Op n e +andop f a b = zipWith f a b -- Is any bit set? --anyset :: (PositiveT n) => Op n Bit -anyset :: (Bit -> Bit -> Bit) -> Op D4 Bit +anyset :: NaturalT n => (e -> e -> e) -> e -> Op n e --anyset a b = copy undefined (a' `hwor` b') -anyset f a b = constant (a' `hwor` b') a b +anyset f s a b = constant (f a' b') a b where - a' = foldl f Low a - b' = foldl f Low b + a' = foldl f s a + b' = foldl f s b xhwor = hwor @@ -36,9 +41,10 @@ type Op n e = (TFVec n e -> TFVec n e -> TFVec n e) type Opcode = Bit {-# ANN sim_input TestInput#-} -sim_input = [ (High,$(vectorTH [High,Low,Low,Low]),$(vectorTH [High,Low,Low,Low])) - , (High,$(vectorTH [High,High,High,High]),$(vectorTH [High,High,High,High])) - , (Low,$(vectorTH [High,Low,Low,High]),$(vectorTH [High,Low,High,Low]))] +sim_input :: [(Opcode, TFVec D4 (SizedInt D8), TFVec D4 (SizedInt D8))] +sim_input = [ (High, $(vectorTH ([4,3,2,1]::[SizedInt D8])), $(vectorTH ([1,2,3,4]::[SizedInt D8]))) + , (High, $(vectorTH ([4,3,2,1]::[SizedInt D8])), $(vectorTH ([1,2,3,4]::[SizedInt D8]))) + , (Low, $(vectorTH ([4,3,2,1]::[SizedInt D8])), $(vectorTH ([1,2,3,4]::[SizedInt D8]))) ] {-# ANN actual_alu InitState #-} initstate = High @@ -50,6 +56,8 @@ alu op1 op2 opc a b = High -> op2 a b {-# ANN actual_alu TopEntity #-} -actual_alu :: (Opcode, TFVec D4 Bit, TFVec D4 Bit) -> TFVec D4 Bit +actual_alu :: (Opcode, TFVec D4 (SizedInt D8), TFVec D4 (SizedInt D8)) -> TFVec D4 (SizedInt D8) --actual_alu = alu (constant Low) andop -actual_alu (opc, a, b) = alu (anyset xhwor) (andop) opc a b +actual_alu (opc, a, b) = alu (anyset (+) (0 :: SizedInt D8)) (andop (-)) opc a b + +runalu = P.map actual_alu sim_input \ No newline at end of file diff --git "a/c\316\273ash/CLasH/Normalize.hs" "b/c\316\273ash/CLasH/Normalize.hs" index 6096c65..e69db2c 100644 --- "a/c\316\273ash/CLasH/Normalize.hs" +++ "b/c\316\273ash/CLasH/Normalize.hs" @@ -102,10 +102,11 @@ letrectop = everywhere ("letrec", letrec) -------------------------------- letsimpl, letsimpltop :: Transform -- Put the "in ..." value of a let in its own binding, but not when the --- expression is applicable (to prevent loops with inlinefun). -letsimpl expr@(Let (Rec binds) res) | not $ is_applicable expr = do +-- expression is already a local variable, or not representable (to prevent loops with inlinenonrep). +letsimpl expr@(Let (Rec binds) res) = do + repr <- isRepr res local_var <- Trans.lift $ is_local_var res - if not local_var + if not local_var && repr then do -- If the result is not a local var already (to prevent loops with -- ourselves), extract it. diff --git "a/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" "b/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" index 42373a4..254f77a 100644 --- "a/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" +++ "b/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" @@ -45,7 +45,7 @@ eval_tfp_int env ty = -- Automatically import modules for any fully qualified identifiers setDynFlag DynFlags.Opt_ImplicitImportQualified - let from_int_t_name = mkRdrName "Types.Data.Num" "fromIntegerT" + let from_int_t_name = mkRdrName "Types.Data.Num.Ops" "fromIntegerT" let from_int_t = SrcLoc.noLoc $ HsExpr.HsVar from_int_t_name let undef = hsTypedUndef $ coreToHsType ty let app = SrcLoc.noLoc $ HsExpr.HsApp (from_int_t) (undef) diff --git "a/c\316\273ash/CLasH/VHDL.hs" "b/c\316\273ash/CLasH/VHDL.hs" index ad7b39b..60b4f8a 100644 --- "a/c\316\273ash/CLasH/VHDL.hs" +++ "b/c\316\273ash/CLasH/VHDL.hs" @@ -240,15 +240,6 @@ getSignalId info = (error $ "Unnamed signal? This should not happen!") (sigName info) -} - -mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (Maybe AST.SigDec) -mkSigDec bndr = - if True then do --isInternalSigUse use || isStateSigUse use then do - let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr - type_mark <- MonadState.lift vsType $ vhdl_ty error_msg (Var.varType bndr) - return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing) - else - return Nothing -- | Transforms a core binding into a VHDL concurrent statement mkConcSm :: diff --git "a/c\316\273ash/CLasH/VHDL/Constants.hs" "b/c\316\273ash/CLasH/VHDL/Constants.hs" index 66c43a4..d9ed855 100644 --- "a/c\316\273ash/CLasH/VHDL/Constants.hs" +++ "b/c\316\273ash/CLasH/VHDL/Constants.hs" @@ -263,6 +263,12 @@ toUnsignedId = "to_unsigned" resizeId :: String resizeId = "resize" +sizedIntId :: String +sizedIntId = "SizedInt" + +tfvecId :: String +tfvecId = "TFVec" + -- | output file identifier (from std.textio) showIdString :: String showIdString = "show" diff --git "a/c\316\273ash/CLasH/VHDL/Generate.hs" "b/c\316\273ash/CLasH/VHDL/Generate.hs" index a2f2fb1..4a62878 100644 --- "a/c\316\273ash/CLasH/VHDL/Generate.hs" +++ "b/c\316\273ash/CLasH/VHDL/Generate.hs" @@ -161,6 +161,39 @@ genFromInteger' (Left res) f lits = do { genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name +genSizedInt :: BuiltinBuilder +genSizedInt = genFromInteger + +genTFVec :: BuiltinBuilder +genTFVec (Left res) f [Left veclist] = do { + ; let (CoreSyn.Let (CoreSyn.Rec [(bndr, app@(CoreSyn.App _ _))]) rez) = veclist + ; let (CoreSyn.Var f, args) = CoreSyn.collectArgs app + ; let valargs = get_val_args (Var.varType f) args + ; apps <- genApplication (Left bndr) f (map Left valargs) + ; (aap,kooi) <- reduceFSVECListToHsList rez + ; sigs <- mapM (\x -> MonadState.lift vsType $ varToVHDLExpr x) (bndr:aap) + ; let vecsigns = concatsigs sigs + ; let vecassign = mkUncondAssign (Left res) vecsigns + ; sig_dec_maybes <- mapM mkSigDec (bndr:aap) + ; let sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes) + ; let block_label = mkVHDLExtId ("FSVec_" ++ (show (map varToString (bndr:aap)))) + ; let block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs (apps ++ kooi ++ [vecassign]) + ; return $ [AST.CSBSm block] + } + where + concatsigs x = AST.Aggregate (map (\z -> AST.ElemAssoc Nothing z) x) + + +reduceFSVECListToHsList app@(CoreSyn.App _ letexpr) = do + case letexpr of + (CoreSyn.Let (CoreSyn.Rec [(bndr, app@(CoreSyn.App _ _))]) rez) -> do + let (CoreSyn.Var f, args) = CoreSyn.collectArgs app + let valargs = get_val_args (Var.varType f) args + app <- genApplication (Left bndr) f (map Left valargs) + (vars, apps) <- reduceFSVECListToHsList rez + return ((bndr:vars),(app ++ apps)) + otherwise -> return ([],[]) + -- | Generate a generate statement for the builtin function "map" genMap :: BuiltinBuilder @@ -549,6 +582,17 @@ genApplication dst f args = do let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in mkUncondAssign (Right sel_name) arg Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconstructor application without an original binder" + IdInfo.DataConWrapId dc -> case dst of + -- It's a datacon. Create a record from its arguments. + Left bndr -> do + case (Map.lookup (varToString f) globalNameTable) of + Just (arg_count, builder) -> + if length args == arg_count then + builder dst f args + else + error $ "\nGenerate.genApplication(DataConWrapId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args + Nothing -> error $ "\nGenerate.genApplication: Can't generate dataconwrapper: " ++ (show dc) + Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconwrapper application without an original binder" IdInfo.VanillaId -> do -- It's a global value imported from elsewhere. These can be builtin -- functions. Look up the function name in the name table and execute @@ -561,7 +605,7 @@ genApplication dst f args = do builder dst f args else error $ "\nGenerate.genApplication(VanillaGlobal): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args - Nothing -> error $ "\nGenerate.genApplication(VanillaGlobal): Using function from another module that is not a known builtin: " ++ pprString f + Nothing -> return $ trace ("\nGenerate.genApplication(VanillaGlobal): Using function from another module that is not a known builtin: " ++ (pprString f)) [] IdInfo.ClassOpId cls -> do -- FIXME: Not looking for what instance this class op is called for -- Is quite stupid of course. @@ -1012,4 +1056,6 @@ globalNameTable = Map.fromList , (fromSizedWordId , (1, genFromSizedWord ) ) , (fromIntegerId , (1, genFromInteger ) ) , (resizeId , (1, genResize ) ) + , (sizedIntId , (1, genSizedInt ) ) + , (tfvecId , (1, genTFVec ) ) ] diff --git "a/c\316\273ash/CLasH/VHDL/VHDLTools.hs" "b/c\316\273ash/CLasH/VHDL/VHDLTools.hs" index 6e9dbe3..d1c008e 100644 --- "a/c\316\273ash/CLasH/VHDL/VHDLTools.hs" +++ "b/c\316\273ash/CLasH/VHDL/VHDLTools.hs" @@ -10,6 +10,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 Data.Accessor.MonadState as MonadState import Debug.Trace -- ForSyDe @@ -395,7 +396,7 @@ mk_vector_ty ty = do modA vsTypes (Map.insert (StdType $ OrdType vec_ty) (vec_id, (Left vec_def))) modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))]) let vecShowFuns = mkVectorShow el_ty_tm vec_id - mapM_ (\(id, subprog) -> modA vsTypeFuns $ Map.insert (OrdType el_ty, id) ((mkVHDLExtId id), subprog)) vecShowFuns + mapM_ (\(id, subprog) -> modA vsTypeFuns $ Map.insert (OrdType vec_ty, id) ((mkVHDLExtId id), subprog)) vecShowFuns let ty_def = AST.SubtypeIn vec_id (Just range) return (Right (ty_id, Right ty_def)) -- Could not create element type @@ -465,7 +466,7 @@ mkHType ty = do let name = Name.getOccString (TyCon.tyConName tycon) Map.lookup name builtin_types case builtin_ty of - Just typ -> + Just typ -> return $ Right $ BuiltinType $ prettyShow typ Nothing -> case Type.splitTyConApp_maybe ty of @@ -528,8 +529,25 @@ isReprType ty = do Left _ -> False Right _ -> True + tfp_to_int :: Type.Type -> TypeSession Int tfp_to_int ty = do + hscenv <- getA vsHscEnv + let norm_ty = normalise_tfp_int hscenv ty + case Type.splitTyConApp_maybe norm_ty of + Just (tycon, args) -> do + let name = Name.getOccString (TyCon.tyConName tycon) + case name of + "Dec" -> do + len <- tfp_to_int' ty + return len + otherwise -> do + modA vsTfpInts (Map.insert (OrdType norm_ty) (-1)) + return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty)) + Nothing -> return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty)) + +tfp_to_int' :: Type.Type -> TypeSession Int +tfp_to_int' ty = do lens <- getA vsTfpInts hscenv <- getA vsHscEnv let norm_ty = normalise_tfp_int hscenv ty @@ -674,4 +692,12 @@ genExprPCall2 :: AST.VHDLId -> AST.Expr -> AST.Expr -> AST.SeqSm genExprPCall2 entid arg1 arg2 = AST.ProcCall (AST.NSimple entid) $ map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2] - \ No newline at end of file + +mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (Maybe AST.SigDec) +mkSigDec bndr = + if True then do --isInternalSigUse use || isStateSigUse use then do + let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr + type_mark <- MonadState.lift vsType $ vhdl_ty error_msg (Var.varType bndr) + return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing) + else + return Nothing -- 2.30.2