From: Christiaan Baaij <christiaan.baaij@gmail.com>
Date: Fri, 31 Jul 2009 07:19:57 +0000 (+0200)
Subject: Quick hack implementation of FSVec literals, needs to be fixed
X-Git-Url: https://git.stderr.nl/gitweb?p=matthijs%2Fmaster-project%2Fc%CE%BBash.git;a=commitdiff_plain;h=04de89474351850ea9dca0350fa383f1b2aff8ea

Quick hack implementation of FSVec literals, needs to be fixed
---

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