-{-# 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
-- 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:
-{-# 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
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
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
--------------------------------
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.
-- 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)
(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 ::
resizeId :: String
resizeId = "resize"
+sizedIntId :: String
+sizedIntId = "SizedInt"
+
+tfvecId :: String
+tfvecId = "TFVec"
+
-- | output file identifier (from std.textio)
showIdString :: String
showIdString = "show"
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
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
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.
, (fromSizedWordId , (1, genFromSizedWord ) )
, (fromIntegerId , (1, genFromInteger ) )
, (resizeId , (1, genResize ) )
+ , (sizedIntId , (1, genSizedInt ) )
+ , (tfvecId , (1, genTFVec ) )
]
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
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
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
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
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
projects / matthijs / master-project / cλash.git / commitdiff