Fix builtin functions (!),take and RangedWord

[matthijs/master-project/cλash.git] / cλash / CLasH / VHDL / Generate.hs

diff --git a/cλash/CLasH/VHDL/Generate.hs b/cλash/CLasH/VHDL/Generate.hs
index 619121aeee2cce42075c57eef886565ee1dd3985..5618532c2f1771fd18d88ba417120072e94206fb 100644 (file)
--- a/cλash/CLasH/VHDL/Generate.hs
+++ b/cλash/CLasH/VHDL/Generate.hs
@@ -1,14 +1,9 @@
-{-# LANGUAGE PackageImports #-}
-

 module CLasH.VHDL.Generate where
 
 -- Standard modules
 module CLasH.VHDL.Generate where
 
 -- Standard modules

-import qualified Control.Monad as Monad

 import qualified Data.Map as Map
 import qualified Maybe
 import qualified Data.Either as Either
 import qualified Data.Map as Map
 import qualified Maybe
 import qualified Data.Either as Either

-import qualified Control.Monad.Trans.State as State
-import qualified "transformers" Control.Monad.Identity as Identity

 import Data.Accessor
 import Data.Accessor.MonadState as MonadState
 import Debug.Trace
 import Data.Accessor
 import Data.Accessor.MonadState as MonadState
 import Debug.Trace


@@ -17,8 +12,8 @@ import Debug.Trace
 import qualified Language.VHDL.AST as AST
 
 -- GHC API
 import qualified Language.VHDL.AST as AST
 
 -- GHC API

-import CoreSyn
-import Type
+import qualified CoreSyn
+import qualified Type

 import qualified Var
 import qualified IdInfo
 import qualified Literal
 import qualified Var
 import qualified IdInfo
 import qualified Literal


@@ -151,12 +146,17 @@ genFromInteger' (Left res) f lits = do {
         ; (tycon, args) = Type.splitTyConApp ty
         ; name = Name.getOccString (TyCon.tyConName tycon)
         } ;
         ; (tycon, args) = Type.splitTyConApp ty
         ; name = Name.getOccString (TyCon.tyConName tycon)
         } ;

-  ; len <- case name of
-    "SizedInt" -> MonadState.lift vsType $ tfp_to_int (sized_int_len_ty ty)
-    "SizedWord" -> MonadState.lift vsType $ tfp_to_int (sized_word_len_ty ty)
-  ; let fname = case name of "SizedInt" -> toSignedId ; "SizedWord" -> toUnsignedId
-  ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname)) 
-            [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show (last lits))), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
+  ; case name of
+    "RangedWord" -> return $ AST.PrimLit (show (last lits))
+    otherwise -> do {
+      ; len <- case name of
+        "SizedInt" -> MonadState.lift vsType $ tfp_to_int (sized_int_len_ty ty)
+        "SizedWord" -> MonadState.lift vsType $ tfp_to_int (sized_word_len_ty ty)
+        "RangedWord" -> MonadState.lift vsType $ tfp_to_int (ranged_word_bound_ty ty)
+      ; let fname = case name of "SizedInt" -> toSignedId ; "SizedWord" -> toUnsignedId
+      ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname))
+                [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show (last lits))), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
+      }

   }
 
 genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
   }
 
 genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name


@@ -164,48 +164,79 @@ genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot g
 genSizedInt :: BuiltinBuilder
 genSizedInt = genFromInteger
 
 genSizedInt :: BuiltinBuilder
 genSizedInt = genFromInteger
 

+-- | Generate a Builder for the builtin datacon TFVec

 genTFVec :: BuiltinBuilder
 genTFVec :: BuiltinBuilder

-genTFVec (Left res) f [Left veclist] = do {
-  ; let (CoreSyn.Let (CoreSyn.Rec letbndrs) rez) = veclist
-  ; letapps <- mapM genLetApp letbndrs
-  ; let bndrs = Maybe.catMaybes (map fst letapps)
-  ; (aap,kooi) <- reduceFSVECListToHsList rez
-  ; sigs <- mapM (\x -> MonadState.lift vsType $ varToVHDLExpr x) (bndrs ++ aap)
-  ; let vecsigns = concatsigs sigs
-  ; let vecassign = mkUncondAssign (Left res) vecsigns
-  ; sig_dec_maybes <- mapM mkSigDec (bndrs ++ aap)
-  ; let sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes)
-  ; let block_label = mkVHDLExtId ("FSVec_" ++ (show (map varToString (bndrs ++ aap))))
-  ; let block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs ((concat (map snd letapps)) ++ kooi ++ [vecassign])  
+genTFVec (Left res) f [Left (CoreSyn.Let (CoreSyn.Rec letBinders) letRes)] = do {
+  -- Generate Assignments for all the binders
+  ; letAssigns <- mapM genBinderAssign letBinders
+  -- Generate assignments for the result (which might be another let binding)
+  ; (resBinders,resAssignments) <- genResAssign letRes
+  -- Get all the Assigned binders
+  ; let assignedBinders = Maybe.catMaybes (map fst letAssigns)
+  -- Make signal names for all the assigned binders
+  ; sigs <- mapM (\x -> MonadState.lift vsType $ varToVHDLExpr x) (assignedBinders ++ resBinders)
+  -- Assign all the signals to the resulting vector
+  ; let { vecsigns = mkAggregateSignal sigs
+        ; vecassign = mkUncondAssign (Left res) vecsigns
+        } ;
+  -- Generate all the signal declaration for the assigned binders
+  ; sig_dec_maybes <- mapM mkSigDec (assignedBinders ++ resBinders)
+  ; let { sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes)
+  -- Setup the VHDL Block
+        ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
+        ; block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs ((concat (map snd letAssigns)) ++ resAssignments ++ [vecassign])
+        } ;
+  -- Return the block statement coressponding to the TFVec literal

   ; return $ [AST.CSBSm block]
   }
   where
   ; return $ [AST.CSBSm block]
   }
   where

-    concatsigs x = AST.Aggregate (map (\z -> AST.ElemAssoc Nothing z) x) 
+    genBinderAssign :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> VHDLSession (Maybe CoreSyn.CoreBndr, [AST.ConcSm])
+    -- For now we only translate applications
+    genBinderAssign (bndr, app@(CoreSyn.App _ _)) = do
+      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)
+      return (Just bndr, apps)
+    genBinderAssign _ = return (Nothing,[])
+    genResAssign :: CoreSyn.CoreExpr -> VHDLSession ([CoreSyn.CoreBndr], [AST.ConcSm])
+    genResAssign app@(CoreSyn.App _ letexpr) = do
+      case letexpr of
+        (CoreSyn.Let (CoreSyn.Rec letbndrs) letres) -> do
+          letapps <- mapM genBinderAssign letbndrs
+          let bndrs = Maybe.catMaybes (map fst letapps)
+          let app = (map snd letapps)
+          (vars, apps) <- genResAssign letres
+          return ((bndrs ++ vars),((concat app) ++ apps))
+        otherwise -> return ([],[])
+    genResAssign _ = return ([],[])

 
 

-genLetApp :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> VHDLSession (Maybe CoreSyn.CoreBndr, [AST.ConcSm])
-genLetApp (bndr, app@(CoreSyn.App _ _)) = do
-  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)
-  return (Just bndr, apps)
+genTFVec (Left res) f [Left app@(CoreSyn.App _ _)] = do {
+  ; let { elems = reduceCoreListToHsList app
+  -- Make signal names for all the binders
+        ; binders = map (\expr -> case expr of 
+                          (CoreSyn.Var b) -> b
+                          otherwise -> error $ "\nGenerate.genTFVec: Cannot generate TFVec: " 
+                            ++ show res ++ ", with elems:\n" ++ show elems ++ "\n" ++ pprString elems) elems
+        } ;
+  ; sigs <- mapM (\x -> MonadState.lift vsType $ varToVHDLExpr x) binders
+  -- Assign all the signals to the resulting vector
+  ; let { vecsigns = mkAggregateSignal sigs
+        ; vecassign = mkUncondAssign (Left res) vecsigns
+  -- Setup the VHDL Block
+        ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
+        ; block = AST.BlockSm block_label [] (AST.PMapAspect []) [] [vecassign]
+        } ;
+  -- Return the block statement coressponding to the TFVec literal
+  ; return $ [AST.CSBSm block]
+  }

   
   

-genLetApp _ = return (Nothing,[])
-
-reduceFSVECListToHsList :: CoreSyn.CoreExpr -> VHDLSession ([CoreSyn.CoreBndr], [AST.ConcSm])
-reduceFSVECListToHsList app@(CoreSyn.App _ letexpr) = do
-  case letexpr of
-    (CoreSyn.Let (CoreSyn.Rec letbndrs) rez) -> do
-      letapps <- mapM genLetApp letbndrs
-      let bndrs = Maybe.catMaybes (map fst letapps)
-      let app = (map snd letapps)
-      (vars, apps) <- reduceFSVECListToHsList rez
-      return ((bndrs ++ vars),((concat app) ++ apps))
-    otherwise -> return ([],[])
+genTFVec (Left name) _ [Left xs] = error $ "\nGenerate.genTFVec: Cannot generate TFVec: " ++ show name ++ ", with elems:\n" ++ show xs ++ "\n" ++ pprString xs

 
 

+genTFVec (Right name) _ _ = error $ "\nGenerate.genTFVec: Cannot generate TFVec assigned to VHDLName: " ++ show name

 
 -- | Generate a generate statement for the builtin function "map"
 genMap :: BuiltinBuilder
 
 -- | Generate a generate statement for the builtin function "map"
 genMap :: BuiltinBuilder

-genMap (Left res) f [Left mapped_f, Left (Var arg)] = do {
+genMap (Left res) f [Left mapped_f, Left (CoreSyn.Var arg)] = do {

   -- mapped_f must be a CoreExpr (since we can't represent functions as VHDL
   -- expressions). arg must be a CoreExpr (and should be a CoreSyn.Var), since
   -- we must index it (which we couldn't if it was a VHDL Expr, since only
   -- mapped_f must be a CoreExpr (since we can't represent functions as VHDL
   -- expressions). arg must be a CoreExpr (and should be a CoreSyn.Var), since
   -- we must index it (which we couldn't if it was a VHDL Expr, since only


@@ -281,7 +312,7 @@ genFold'' len left (Left res) f [folded_f, start, vec] = do
   -- An expression for len-1
   let len_min_expr = (AST.PrimLit $ show (len-1))
   -- evec is (TFVec n), so it still needs an element type
   -- An expression for len-1
   let len_min_expr = (AST.PrimLit $ show (len-1))
   -- evec is (TFVec n), so it still needs an element type

-  let (nvec, _) = splitAppTy (Var.varType vec)
+  let (nvec, _) = Type.splitAppTy (Var.varType vec)

   -- Put the type of the start value in nvec, this will be the type of our
   -- temporary vector
   let tmp_ty = Type.mkAppTy nvec (Var.varType start)
   -- Put the type of the start value in nvec, this will be the type of our
   -- temporary vector
   let tmp_ty = Type.mkAppTy nvec (Var.varType start)


@@ -429,7 +460,7 @@ genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var
 genConcat' (Left res) f args@[arg] = do {
     -- Setup the generate scheme
   ; len1 <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
 genConcat' (Left res) f args@[arg] = do {
     -- Setup the generate scheme
   ; len1 <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg

-  ; let (_, nvec) = splitAppTy (Var.varType arg)
+  ; let (_, nvec) = Type.splitAppTy (Var.varType arg)

   ; len2 <- MonadState.lift vsType $ tfp_to_int $ tfvec_len_ty nvec
           -- TODO: Use something better than varToString
   ; let { label       = mkVHDLExtId ("concatVector" ++ (varToString res))
   ; len2 <- MonadState.lift vsType $ tfp_to_int $ tfvec_len_ty nvec
           -- TODO: Use something better than varToString
   ; let { label       = mkVHDLExtId ("concatVector" ++ (varToString res))


@@ -663,7 +694,8 @@ genUnconsVectorFuns elemTM vectorTM  =
   , (replaceId, (AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr,replaceRet],[]))
   , (lastId, (AST.SubProgBody lastSpec    []                  [lastExpr],[]))
   , (initId, (AST.SubProgBody initSpec    [AST.SPVD initVar]  [initExpr, initRet],[]))
   , (replaceId, (AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr,replaceRet],[]))
   , (lastId, (AST.SubProgBody lastSpec    []                  [lastExpr],[]))
   , (initId, (AST.SubProgBody initSpec    [AST.SPVD initVar]  [initExpr, initRet],[]))

-  , (takeId, (AST.SubProgBody takeSpec    [AST.SPVD takeVar]  [takeExpr, takeRet],[]))
+  , (minimumId, (AST.SubProgBody minimumSpec [] [minimumExpr],[]))
+  , (takeId, (AST.SubProgBody takeSpec    [AST.SPVD takeVar]  [takeExpr, takeRet],[minimumId]))

   , (dropId, (AST.SubProgBody dropSpec    [AST.SPVD dropVar]  [dropExpr, dropRet],[]))
   , (plusgtId, (AST.SubProgBody plusgtSpec  [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[]))
   , (emptyId, (AST.SubProgBody emptySpec   [AST.SPCD emptyVar] [emptyExpr],[]))
   , (dropId, (AST.SubProgBody dropSpec    [AST.SPVD dropVar]  [dropExpr, dropRet],[]))
   , (plusgtId, (AST.SubProgBody plusgtSpec  [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[]))
   , (emptyId, (AST.SubProgBody emptySpec   [AST.SPCD emptyVar] [emptyExpr],[]))


@@ -686,12 +718,14 @@ genUnconsVectorFuns elemTM vectorTM  =
     vec1Par = AST.unsafeVHDLBasicId "vec1"
     vec2Par = AST.unsafeVHDLBasicId "vec2"
     nPar    = AST.unsafeVHDLBasicId "n"
     vec1Par = AST.unsafeVHDLBasicId "vec1"
     vec2Par = AST.unsafeVHDLBasicId "vec2"
     nPar    = AST.unsafeVHDLBasicId "n"

+    leftPar = AST.unsafeVHDLBasicId "nLeft"
+    rightPar = AST.unsafeVHDLBasicId "nRight"

     iId     = AST.unsafeVHDLBasicId "i"
     iPar    = iId
     aPar    = AST.unsafeVHDLBasicId "a"
     fPar = AST.unsafeVHDLBasicId "f"
     sPar = AST.unsafeVHDLBasicId "s"
     iId     = AST.unsafeVHDLBasicId "i"
     iPar    = iId
     aPar    = AST.unsafeVHDLBasicId "a"
     fPar = AST.unsafeVHDLBasicId "f"
     sPar = AST.unsafeVHDLBasicId "s"

-    resId   = AST.unsafeVHDLBasicId "res"
+    resId   = AST.unsafeVHDLBasicId "res"    

     exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
                                AST.IfaceVarDec ixPar  naturalTM] elemTM
     exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed 
     exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
                                AST.IfaceVarDec ixPar  naturalTM] elemTM
     exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed 


@@ -749,21 +783,32 @@ genUnconsVectorFuns elemTM vectorTM  =
                                   AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) 
                                                              AST.:-: AST.PrimLit "2"))
     initRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
                                   AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) 
                                                              AST.:-: AST.PrimLit "2"))
     initRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)

+    minimumSpec = AST.Function (mkVHDLExtId minimumId) [AST.IfaceVarDec leftPar   naturalTM,
+                                   AST.IfaceVarDec rightPar naturalTM ] naturalTM
+    minimumExpr = AST.IfSm ((AST.PrimName $ AST.NSimple leftPar) AST.:<: (AST.PrimName $ AST.NSimple rightPar))
+                        [AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple leftPar)]
+                        []
+                        (Just $ AST.Else [minimumExprRet])
+      where minimumExprRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple rightPar)

     takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar   naturalTM,
                                    AST.IfaceVarDec vecPar vectorTM ] vectorTM
     takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar   naturalTM,
                                    AST.IfaceVarDec vecPar vectorTM ] vectorTM

-       -- variable res : fsvec_x (0 to n-1);
+       -- variable res : fsvec_x (0 to (minimum (n,vec'length))-1);
+    minLength = AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId minimumId))  
+                              [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple nPar)
+                              ,Nothing AST.:=>: AST.ADExpr (AST.PrimName (AST.NAttribute $ 
+                                AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]

     takeVar = 
          AST.VarDec resId 
                 (AST.SubtypeIn vectorTM
                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
                    [AST.ToRange (AST.PrimLit "0")
     takeVar = 
          AST.VarDec resId 
                 (AST.SubtypeIn vectorTM
                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
                    [AST.ToRange (AST.PrimLit "0")

-                               ((AST.PrimName (AST.NSimple nPar)) AST.:-:
+                               (minLength AST.:-:

                                 (AST.PrimLit "1"))   ]))
                 Nothing
        -- res AST.:= vec(0 to n-1)
     takeExpr = AST.NSimple resId AST.:= 
                                 (AST.PrimLit "1"))   ]))
                 Nothing
        -- res AST.:= vec(0 to n-1)
     takeExpr = AST.NSimple resId AST.:= 

-                    (vecSlice (AST.PrimLit "1") 
-                              (AST.PrimName (AST.NSimple $ nPar) AST.:-: AST.PrimLit "1"))
+                    (vecSlice (AST.PrimLit "0") 
+                              (minLength AST.:-: AST.PrimLit "1"))

     takeRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
     dropSpec = AST.Function (mkVHDLExtId dropId) [AST.IfaceVarDec nPar   naturalTM,
                                    AST.IfaceVarDec vecPar vectorTM ] vectorTM 
     takeRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
     dropSpec = AST.Function (mkVHDLExtId dropId) [AST.IfaceVarDec nPar   naturalTM,
                                    AST.IfaceVarDec vecPar vectorTM ] vectorTM 


@@ -1019,7 +1064,7 @@ genUnconsVectorFuns elemTM vectorTM  =
 -- builder function.
 globalNameTable :: NameTable
 globalNameTable = Map.fromList
 -- builder function.
 globalNameTable :: NameTable
 globalNameTable = Map.fromList

-  [ (exId             , (2, genFCall False          ) )
+  [ (exId             , (2, genFCall True          ) )

   , (replaceId        , (3, genFCall False          ) )
   , (headId           , (1, genFCall True           ) )
   , (lastId           , (1, genFCall True           ) )
   , (replaceId        , (3, genFCall False          ) )
   , (headId           , (1, genFCall True           ) )
   , (lastId           , (1, genFCall True           ) )


@@ -1066,4 +1111,5 @@ globalNameTable = Map.fromList
   , (resizeId         , (1, genResize               ) )
   , (sizedIntId       , (1, genSizedInt             ) )
   , (tfvecId          , (1, genTFVec                ) )
   , (resizeId         , (1, genResize               ) )
   , (sizedIntId       , (1, genSizedInt             ) )
   , (tfvecId          , (1, genTFVec                ) )

+  , (minimumId        , (2, error $ "\nFunction name: \"minimum\" is used internally, use another name"))

   ]
   ]