Add support for multiple alts in case statements

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

diff --git a/cλash/CLasH/VHDL/VHDLTools.hs b/cλash/CLasH/VHDL/VHDLTools.hs
index 4c41d8fab2221de65114f68a8c62ee62eaf2d674..785b528afb1140db80655c62a7346b6a3bdc2f88 100644 (file)
--- a/cλash/CLasH/VHDL/VHDLTools.hs
+++ b/cλash/CLasH/VHDL/VHDLTools.hs
@@ -5,6 +5,7 @@ module CLasH.VHDL.VHDLTools where
 import qualified Maybe
 import qualified Data.Either as Either
 import qualified Data.List as List
 import qualified Maybe
 import qualified Data.Either as Either
 import qualified Data.List as List

+import qualified Data.Char as Char

 import qualified Data.Map as Map
 import qualified Control.Monad as Monad
 import qualified Control.Arrow as Arrow
 import qualified Data.Map as Map
 import qualified Control.Monad as Monad
 import qualified Control.Arrow as Arrow


@@ -72,7 +73,7 @@ mkAssign dst cond false_expr =
     whenelse = case cond of
       Just (cond_expr, true_expr) -> 
         let 
     whenelse = case cond of
       Just (cond_expr, true_expr) -> 
         let 

-          true_wform = AST.Wform [AST.WformElem true_expr Nothing] 
+          true_wform = AST.Wform [AST.WformElem true_expr Nothing]

         in
           [AST.WhenElse true_wform cond_expr]
       Nothing -> []
         in
           [AST.WhenElse true_wform cond_expr]
       Nothing -> []


@@ -84,6 +85,31 @@ mkAssign dst cond false_expr =
   in
     AST.CSSASm assign
 
   in
     AST.CSSASm assign
 

+mkAltsAssign ::
+  Either CoreBndr AST.VHDLName            -- ^ The signal to assign to
+  -> [AST.Expr]       -- ^ The conditions
+  -> [AST.Expr]       -- ^ The expressions
+  -> AST.ConcSm   -- ^ The Alt assigns
+mkAltsAssign dst conds exprs
+        | (length conds) /= ((length exprs) - 1) = error $ "\nVHDLTools.mkAltsAssign: conditions expression mismatch"
+        | otherwise =
+  let
+    whenelses   = zipWith mkWhenElse conds exprs
+    false_wform = AST.Wform [AST.WformElem (last exprs) Nothing]
+    dst_name  = case dst of
+      Left bndr -> AST.NSimple (varToVHDLId bndr)
+      Right name -> name
+    assign    = dst_name AST.:<==: (AST.ConWforms whenelses false_wform Nothing)
+  in
+    AST.CSSASm assign
+  where
+    mkWhenElse :: AST.Expr -> AST.Expr -> AST.WhenElse
+    mkWhenElse cond true_expr =
+      let
+        true_wform = AST.Wform [AST.WformElem true_expr Nothing]
+      in
+        AST.WhenElse true_wform cond
+

 mkAssocElems :: 
   [AST.Expr]                    -- ^ The argument that are applied to function
   -> AST.VHDLName               -- ^ The binder in which to store the result
 mkAssocElems :: 
   [AST.Expr]                    -- ^ The argument that are applied to function
   -> AST.VHDLName               -- ^ The binder in which to store the result


@@ -118,7 +144,8 @@ mkComponentInst label entity_id portassigns = AST.CSISm compins
   where
     -- We always have a clock port, so no need to map it anywhere but here
     clk_port = mkAssocElem clockId (idToVHDLExpr clockId)
   where
     -- We always have a clock port, so no need to map it anywhere but here
     clk_port = mkAssocElem clockId (idToVHDLExpr clockId)

-    compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port]))
+    resetn_port = mkAssocElem resetId (idToVHDLExpr resetId)
+    compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port,resetn_port]))

 
 -----------------------------------------------------------------------------
 -- Functions to generate VHDL Exprs
 
 -----------------------------------------------------------------------------
 -- Functions to generate VHDL Exprs


@@ -127,7 +154,7 @@ mkComponentInst label entity_id portassigns = AST.CSISm compins
 varToVHDLExpr :: Var.Var -> TypeSession AST.Expr
 varToVHDLExpr var = do
   case Id.isDataConWorkId_maybe var of
 varToVHDLExpr :: Var.Var -> TypeSession AST.Expr
 varToVHDLExpr var = do
   case Id.isDataConWorkId_maybe var of

-    Just dc -> return $ dataconToVHDLExpr dc
+    Just dc -> dataconToVHDLExpr dc

     -- This is a dataconstructor.
     -- Not a datacon, just another signal. Perhaps we should check for
     -- local/global here as well?
     -- This is a dataconstructor.
     -- Not a datacon, just another signal. Perhaps we should check for
     -- local/global here as well?


@@ -157,23 +184,37 @@ exprToVHDLExpr core = varToVHDLExpr (exprToVar core)
 -- Turn a alternative constructor into an AST expression. For
 -- dataconstructors, this is only the constructor itself, not any arguments it
 -- has. Should not be called with a DEFAULT constructor.
 -- Turn a alternative constructor into an AST expression. For
 -- dataconstructors, this is only the constructor itself, not any arguments it
 -- has. Should not be called with a DEFAULT constructor.

-altconToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
+altconToVHDLExpr :: CoreSyn.AltCon -> TypeSession AST.Expr

 altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc
 
 altconToVHDLExpr (LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet"
 altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc
 
 altconToVHDLExpr (LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet"

-altconToVHDLExpr DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!"
+altconToVHDLExpr DEFAULT = return $ AST.PrimLit "undefined" -- error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!"

 
 -- Turn a datacon (without arguments!) into a VHDL expression.
 
 -- Turn a datacon (without arguments!) into a VHDL expression.

-dataconToVHDLExpr :: DataCon.DataCon -> AST.Expr
-dataconToVHDLExpr dc = AST.PrimLit lit
-  where
-    tycon = DataCon.dataConTyCon dc
-    tyname = TyCon.tyConName tycon
-    dcname = DataCon.dataConName dc
-    lit = case Name.getOccString tyname of
-      -- TODO: Do something more robust than string matching
-      "Bit"      -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
-      "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
+dataconToVHDLExpr :: DataCon.DataCon -> TypeSession AST.Expr
+dataconToVHDLExpr dc = do
+  typemap <- getA tsTypes
+  htype_either <- mkHType (DataCon.dataConRepType dc)
+  case htype_either of
+    -- No errors
+    Right htype -> do
+      let existing_ty = (Monad.liftM $ fmap fst) $ Map.lookup htype typemap
+      case existing_ty of
+        Just ty -> do
+          let dcname = DataCon.dataConName dc
+          let lit    = idToVHDLExpr $ mkVHDLExtId $ Name.getOccString dcname
+          return lit
+        Nothing -> do
+          let tycon = DataCon.dataConTyCon dc
+          let tyname = TyCon.tyConName tycon
+          let dcname = DataCon.dataConName dc
+          let lit = case Name.getOccString tyname of
+              -- TODO: Do something more robust than string matching
+                "Bit"  -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
+                "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
+          return $ AST.PrimLit lit
+    -- Error when constructing htype
+    Left err -> error err

 
 -----------------------------------------------------------------------------
 -- Functions dealing with names, variables and ids
 
 -----------------------------------------------------------------------------
 -- Functions dealing with names, variables and ids


@@ -183,7 +224,10 @@ dataconToVHDLExpr dc = AST.PrimLit lit
 varToVHDLId ::
   CoreSyn.CoreBndr
   -> AST.VHDLId
 varToVHDLId ::
   CoreSyn.CoreBndr
   -> AST.VHDLId

-varToVHDLId = mkVHDLExtId . varToString
+varToVHDLId var = mkVHDLExtId $ (varToString var ++ varToStringUniq var ++ (show $ lowers $ varToStringUniq var))
+  where
+    lowers :: String -> Int
+    lowers xs = length [x | x <- xs, Char.isLower x]

 
 -- Creates a VHDL Name from a binder
 varToVHDLName ::
 
 -- Creates a VHDL Name from a binder
 varToVHDLName ::


@@ -234,7 +278,7 @@ mkVHDLExtId s =
   AST.unsafeVHDLExtId $ strip_invalid s
   where 
     -- Allowed characters, taken from ForSyde's mkVHDLExtId
   AST.unsafeVHDLExtId $ strip_invalid s
   where 
     -- Allowed characters, taken from ForSyde's mkVHDLExtId

-    allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
+    allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&'()*+,./:;<=>_|!$%@?[]^`{}~-"

     strip_invalid = filter (`elem` allowed)
 
 -- Create a record field selector that selects the given label from the record
     strip_invalid = filter (`elem` allowed)
 
 -- Create a record field selector that selects the given label from the record


@@ -285,7 +329,8 @@ vhdl_ty_either tything =
     Just ty -> vhdl_ty_either' ty
 
 vhdl_ty_either' :: Type.Type -> TypeSession (Either String (Maybe AST.TypeMark))
     Just ty -> vhdl_ty_either' ty
 
 vhdl_ty_either' :: Type.Type -> TypeSession (Either String (Maybe AST.TypeMark))

-vhdl_ty_either' ty = do
+vhdl_ty_either' ty | ty_has_free_tyvars ty = return $ Left $ "VHDLTools.vhdl_ty_either': Cannot create type: type has free type variables: " ++ pprString ty
+                   | otherwise = do

   typemap <- getA tsTypes
   htype_either <- mkHType ty
   case htype_either of
   typemap <- getA tsTypes
   htype_either <- mkHType ty
   case htype_either of


@@ -374,7 +419,19 @@ mk_tycon_ty ty tycon args =
         (errors, _) -> return $ Left $
           "VHDLTools.mk_tycon_ty: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
           ++ (concat errors)
         (errors, _) -> return $ Left $
           "VHDLTools.mk_tycon_ty: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
           ++ (concat errors)

-    dcs -> return $ Left $ "VHDLTools.mk_tycon_ty: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
+    dcs -> do
+      let arg_tys = concat $ map DataCon.dataConRepArgTys dcs
+      let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
+      case real_arg_tys of
+        [] -> do
+          let elems = map (mkVHDLExtId . nameToString . DataCon.dataConName) dcs
+          let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon)
+          let ty_def = AST.TDE $ AST.EnumTypeDef elems
+          let enumShow = mkEnumShow elems ty_id
+          modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, enumShow)
+          return $ Right $ Just (ty_id, Left ty_def)
+        xs -> return $ Left $
+          "VHDLTools.mkTyConHType: Only enum-like constructor datatypes supported: " ++ pprString dcs ++ "\n"

   where
     -- Create a subst that instantiates all types passed to the tycon
     -- TODO: I'm not 100% sure that this is the right way to do this. It seems
   where
     -- Create a subst that instantiates all types passed to the tycon
     -- TODO: I'm not 100% sure that this is the right way to do this. It seems


@@ -432,9 +489,10 @@ mk_natural_ty ::
   -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
       -- ^ An error message or The typemark created.
 mk_natural_ty min_bound max_bound = do
   -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
       -- ^ An error message or The typemark created.
 mk_natural_ty min_bound max_bound = do

-  let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
-  let range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit $ (show min_bound)) (AST.PrimLit $ (show max_bound))
-  let ty_def = AST.SubtypeIn naturalTM (Just range)
+  let bitsize = floor (logBase 2 (fromInteger (toInteger max_bound)))
+  let ty_id = mkVHDLExtId $ "natural_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
+  let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit $ show min_bound) (AST.PrimLit $ show bitsize)]
+  let ty_def = AST.SubtypeIn unsignedTM (Just range)

   return (Right $ Just (ty_id, Right ty_def))
 
 mk_unsigned_ty ::
   return (Right $ Just (ty_id, Right ty_def))
 
 mk_unsigned_ty ::


@@ -522,7 +580,7 @@ mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType)
 mkTyConHType tycon args =
   case TyCon.tyConDataCons tycon of
     -- Not an algebraic type
 mkTyConHType tycon args =
   case TyCon.tyConDataCons tycon of
     -- Not an algebraic type

-    [] -> return $ Left $ "VHDLTools.mkHType: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n"
+    [] -> return $ Left $ "VHDLTools.mkTyConHType: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n"

     [dc] -> do
       let arg_tys = DataCon.dataConRepArgTys dc
       let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
     [dc] -> do
       let arg_tys = DataCon.dataConRepArgTys dc
       let real_arg_tys = map (CoreSubst.substTy subst) arg_tys


@@ -533,9 +591,16 @@ mkTyConHType tycon args =
           return $ Right $ ADTType (nameToString (TyCon.tyConName tycon)) elem_htys
         -- There were errors in element types
         (errors, _) -> return $ Left $
           return $ Right $ ADTType (nameToString (TyCon.tyConName tycon)) elem_htys
         -- There were errors in element types
         (errors, _) -> return $ Left $

-          "VHDLTools.mkHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
+          "VHDLTools.mkTyConHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"

           ++ (concat errors)
           ++ (concat errors)

-    dcs -> return $ Left $ "VHDLTools.mkHType: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
+    dcs -> do
+      let arg_tys = concat $ map DataCon.dataConRepArgTys dcs
+      let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
+      case real_arg_tys of
+        [] ->
+          return $ Right $ EnumType (nameToString (TyCon.tyConName tycon)) (map (nameToString . DataCon.dataConName) dcs)
+        xs -> return $ Left $
+          "VHDLTools.mkTyConHType: Only enum-like constructor datatypes supported: " ++ pprString dcs ++ "\n"

   where
     tyvars = TyCon.tyConTyVars tycon
     subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
   where
     tyvars = TyCon.tyConTyVars tycon
     subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)


@@ -602,6 +667,17 @@ mkTupleShow elemTMs tupleTM = AST.SubProgBody showSpec [] [showExpr]
     recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
     tupSize = length elemTMs
 
     recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
     tupSize = length elemTMs
 

+mkEnumShow ::
+  [AST.VHDLId]
+  -> AST.TypeMark
+  -> AST.SubProgBody
+mkEnumShow elemIds enumTM = AST.SubProgBody showSpec [] [showExpr]
+  where
+    enumPar    = AST.unsafeVHDLBasicId "enum"
+    showSpec  = AST.Function showId [AST.IfaceVarDec enumPar enumTM] stringTM
+    showExpr  = AST.ReturnSm (Just $
+                  AST.PrimLit (show $ tail $ init $ AST.fromVHDLId enumTM))
+

 mkVectorShow ::
   AST.TypeMark -- ^ elemtype
   -> AST.TypeMark -- ^ vectype
 mkVectorShow ::
   AST.TypeMark -- ^ elemtype
   -> AST.TypeMark -- ^ vectype


@@ -677,14 +753,14 @@ mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr]
                 , AST.SubProgBody showBoolSpec [] [showBoolExpr]
                 , AST.SubProgBody showSingedSpec [] [showSignedExpr]
                 , AST.SubProgBody showUnsignedSpec [] [showUnsignedExpr]
                 , AST.SubProgBody showBoolSpec [] [showBoolExpr]
                 , AST.SubProgBody showSingedSpec [] [showSignedExpr]
                 , AST.SubProgBody showUnsignedSpec [] [showUnsignedExpr]

-                , AST.SubProgBody showNaturalSpec [] [showNaturalExpr]
+                -- , AST.SubProgBody showNaturalSpec [] [showNaturalExpr]

                 ]
   where
     bitPar      = AST.unsafeVHDLBasicId "s"
     boolPar     = AST.unsafeVHDLBasicId "b"
     signedPar   = AST.unsafeVHDLBasicId "sint"
     unsignedPar = AST.unsafeVHDLBasicId "uint"
                 ]
   where
     bitPar      = AST.unsafeVHDLBasicId "s"
     boolPar     = AST.unsafeVHDLBasicId "b"
     signedPar   = AST.unsafeVHDLBasicId "sint"
     unsignedPar = AST.unsafeVHDLBasicId "uint"

-    naturalPar  = AST.unsafeVHDLBasicId "nat"
+    -- naturalPar  = AST.unsafeVHDLBasicId "nat"

     showBitSpec = AST.Function showId [AST.IfaceVarDec bitPar std_logicTM] stringTM
     -- if s = '1' then return "'1'" else return "'0'"
     showBitExpr = AST.IfSm (AST.PrimName (AST.NSimple bitPar) AST.:=: AST.PrimLit "'1'")
     showBitSpec = AST.Function showId [AST.IfaceVarDec bitPar std_logicTM] stringTM
     -- if s = '1' then return "'1'" else return "'0'"
     showBitExpr = AST.IfSm (AST.PrimName (AST.NSimple bitPar) AST.:=: AST.PrimLit "'1'")


@@ -709,10 +785,10 @@ mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr]
                           (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [unsignToInt]) Nothing )
                         where
                           unsignToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ unsignedPar)
                           (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [unsignToInt]) Nothing )
                         where
                           unsignToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ unsignedPar)

-    showNaturalSpec = AST.Function showId [AST.IfaceVarDec naturalPar naturalTM] stringTM
-    showNaturalExpr = AST.ReturnSm (Just $
-                        AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
-                        (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [AST.PrimName $ AST.NSimple $ naturalPar]) Nothing )
+    -- showNaturalSpec = AST.Function showId [AST.IfaceVarDec naturalPar naturalTM] stringTM
+    -- showNaturalExpr = AST.ReturnSm (Just $
+    --                     AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
+    --                     (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [AST.PrimName $ AST.NSimple $ naturalPar]) Nothing )

                       
   
 genExprFCall :: AST.VHDLId -> AST.Expr -> AST.Expr
                       
   
 genExprFCall :: AST.VHDLId -> AST.Expr -> AST.Expr