X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=clash%2FCLasH%2FVHDL%2FVHDLTools.hs;h=f04c1dcfb01af46e6187f6e3cf390184b3a94122;hb=c8676a7aec4420d558936beedfb578479c4575cf;hp=fde81d06dae32e7fbc0b381f16f24e0cb685c602;hpb=1c8a4c9cad0267bc069d29a9522efd828c564147;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/clash/CLasH/VHDL/VHDLTools.hs b/clash/CLasH/VHDL/VHDLTools.hs
index fde81d0..f04c1dc 100644
--- a/clash/CLasH/VHDL/VHDLTools.hs
+++ b/clash/CLasH/VHDL/VHDLTools.hs
@@ -192,7 +192,7 @@ dataconToVHDLExpr dc = do
           let existing_ty = Monad.liftM (fmap fst) $ Map.lookup htype typemap
           case existing_ty of
             Just ty -> do
-              let lit    = idToVHDLExpr $ mkVHDLExtId $ Name.getOccString dcname
+              let lit    = AST.PrimLit $ show $ getConstructorIndex htype $ Name.getOccString dcname
               return lit
             Nothing -> error $ "\nVHDLTools.dataconToVHDLExpr: Trying to make value for non-representable DataCon: " ++ pprString dc
     -- Error when constructing htype
@@ -256,12 +256,18 @@ mkVHDLBasicId s =
 -- basic ids.
 -- Use extended Ids for any values that are taken from the source file.
 mkVHDLExtId :: String -> AST.VHDLId
-mkVHDLExtId s = 
-  AST.unsafeVHDLExtId $ strip_invalid s
+mkVHDLExtId s =
+  (AST.unsafeVHDLBasicId . zEncodeString . strip_multiscore . strip_leading . strip_invalid) s
   where 
     -- Allowed characters, taken from ForSyde's mkVHDLExtId
     allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&'()*+,./:;<=>_|!$%@?[]^`{}~-"
     strip_invalid = filter (`elem` allowed)
+    strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
+    strip_multiscore = concatMap (\cs -> 
+        case cs of 
+          ('_':_) -> "_"
+          _ -> cs
+      ) . List.group
 
 -- Create a record field selector that selects the given label from the record
 -- stored in the given binder.
@@ -495,13 +501,11 @@ mkTyconTy htype =
           return $ Just (ty_id, Just $ Left ty_def)
     (EnumType tycon dcs) -> do
       let ty_id = mkVHDLExtId tycon
-      let possibilaties = case (length dcs) of 1 -> 1; x -> (x-1)
-      let bitsize = floor (logBase 2 (fromInteger (toInteger possibilaties)))
-      let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.DownRange (AST.PrimLit $ show bitsize) (AST.PrimLit "0")]
-      let ty_def = AST.SubtypeIn unsignedTM (Just range)
+      let range = AST.SubTypeRange (AST.PrimLit "0") (AST.PrimLit $ show ((length dcs) - 1))
+      let ty_def = AST.TDI $ AST.IntegerTypeDef range
       let enumShow = mkEnumShow dcs ty_id
       MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, enumShow)
-      return $ Just (ty_id, Just $ Right ty_def)
+      return $ Just (ty_id, Just $ Left ty_def)
     otherwise -> error $ "\nVHDLTools.mkTyconTy: Called for HType that is neiter a AggrType or EnumType: " ++ show htype
 
 -- | Create a VHDL vector type
@@ -543,7 +547,7 @@ mkNaturalTy ::
 mkNaturalTy min_bound max_bound = do
   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 range = AST.ConstraintIndex $ AST.IndexConstraint [AST.DownRange (AST.PrimLit $ show bitsize) (AST.PrimLit $ show min_bound)]
   let ty_def = AST.SubtypeIn unsignedTM (Just range)
   return (Just (ty_id, Just $ Right ty_def))
 
@@ -551,8 +555,8 @@ mkUnsignedTy ::
   Int -- ^ Haskell type of the unsigned integer
   -> TypeSession TypeMapRec
 mkUnsignedTy size = do
-  let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1)
-  let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
+  let ty_id = mkVHDLExtId $ "unsigned_" ++ show size
+  let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.DownRange (AST.PrimLit $ show (size - 1)) (AST.PrimLit "0")]
   let ty_def = AST.SubtypeIn unsignedTM (Just range)
   return (Just (ty_id, Just $ Right ty_def))
   
@@ -560,8 +564,8 @@ mkSignedTy ::
   Int -- ^ Haskell type of the signed integer
   -> TypeSession TypeMapRec
 mkSignedTy size = do
-  let ty_id = mkVHDLExtId $ "signed_" ++ show (size - 1)
-  let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
+  let ty_id = mkVHDLExtId $ "signed_" ++ show size
+  let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.DownRange (AST.PrimLit $ show (size - 1)) (AST.PrimLit "0")]
   let ty_def = AST.SubtypeIn signedTM (Just range)
   return (Just (ty_id, Just $ Right ty_def))
 
@@ -620,7 +624,8 @@ mkTupleShow ::
 mkTupleShow elemTMs tupleTM = AST.SubProgBody showSpec [] [showExpr]
   where
     tupPar    = AST.unsafeVHDLBasicId "tup"
-    showSpec  = AST.Function showId [AST.IfaceVarDec tupPar tupleTM] stringTM
+    parenPar  = AST.unsafeVHDLBasicId "paren"
+    showSpec  = AST.Function showId [AST.IfaceVarDec tupPar tupleTM, AST.IfaceVarDec parenPar booleanTM] stringTM
     showExpr  = AST.ReturnSm (Just $
                   AST.PrimLit "'('" AST.:&: showMiddle AST.:&: AST.PrimLit "')'")
       where
@@ -628,14 +633,11 @@ mkTupleShow elemTMs tupleTM = AST.SubProgBody showSpec [] [showExpr]
             AST.PrimLit "''"
           else
             foldr1 (\e1 e2 -> e1 AST.:&: AST.PrimLit "','" AST.:&: e2) $
-              map ((genExprFCall showId).
-                    AST.PrimName .
-                    AST.NSelected .
-                    (AST.NSimple tupPar AST.:.:).
-                    tupVHDLSuffix)
+              map ((genExprFCall2 showId) . (\x -> (selectedName tupPar x, AST.PrimLit "false")))
                   (take tupSize recordlabels)
     recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
     tupSize = length elemTMs
+    selectedName par = (AST.PrimName . AST.NSelected . (AST.NSimple par AST.:.:) . tupVHDLSuffix)
 
 mkAdtShow ::
   String
@@ -646,19 +648,27 @@ mkAdtShow ::
 mkAdtShow conLbl conIds elemIdss adtTM = AST.SubProgBody showSpec [] [showExpr]
   where  
     adtPar   = AST.unsafeVHDLBasicId "adt"
-    showSpec  = AST.Function showId [AST.IfaceVarDec adtPar adtTM] stringTM
-    showExpr  = AST.CaseSm (AST.PrimName $ AST.NSelected $ (AST.NSimple adtPar) AST.:.: (AST.SSimple $ (mkVHDLBasicId conLbl)))
-                  [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit $ show x] [AST.ReturnSm (Just $ ((AST.PrimLit $ '"':(conIds!!x)++[' ','"'])) AST.:&: showFields x)] | x <- [0..(length conIds) -1]]
+    parenPar = AST.unsafeVHDLBasicId "paren"
+    showSpec  = AST.Function showId [AST.IfaceVarDec adtPar adtTM, AST.IfaceVarDec parenPar booleanTM] stringTM
+    showExpr  = AST.CaseSm ((selectedName adtPar) (mkVHDLBasicId conLbl))
+                  [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit $ show x] (
+                    if (null (elemIdss!!x)) then
+                        [AST.ReturnSm (Just $ ((genExprFCall2 showId) . (\x -> (selectedName adtPar x, AST.PrimLit "false")) $ mkVHDLBasicId conLbl) AST.:&: showFields x)]
+                      else
+                        [addParens (((genExprFCall2 showId) . (\x -> (selectedName adtPar x, AST.PrimLit "false")) $ mkVHDLBasicId conLbl) AST.:&: showFields x)]
+                    ) | x <- [0..(length conIds) -1]]
     showFields i = if (null (elemIdss!!i)) then
-        AST.PrimLit "''"
+        AST.PrimLit "\"\""
       else
-        foldr1 (\e1 e2 -> e1 AST.:&: AST.PrimLit "' '" AST.:&: e2) $
-              map ((genExprFCall showId).
-                    AST.PrimName .
-                    AST.NSelected .
-                    (AST.NSimple adtPar AST.:.:).
-                    tupVHDLSuffix)
-                  (map mkVHDLBasicId (elemIdss!!i))              
+        foldr1 (\e1 e2 -> e1 AST.:&: e2) $
+              map ((AST.PrimLit "' '" AST.:&:) . (genExprFCall2 showId) . (\x -> (selectedName adtPar x, AST.PrimLit "true")))
+                  (map mkVHDLBasicId (elemIdss!!i))
+    selectedName par = (AST.PrimName . AST.NSelected . (AST.NSimple par AST.:.:) . tupVHDLSuffix)
+    addParens :: AST.Expr -> AST.SeqSm
+    addParens k = AST.IfSm (AST.PrimName (AST.NSimple parenPar))
+                    [AST.ReturnSm (Just (AST.PrimLit "'('" AST.:&: k AST.:&: AST.PrimLit "')'" ))]
+                    []
+                    (Just $ AST.Else [AST.ReturnSm (Just k)])
     
 mkEnumShow ::
   [String]
@@ -667,7 +677,8 @@ mkEnumShow ::
 mkEnumShow elemIds enumTM = AST.SubProgBody showSpec [] [showExpr]
   where  
     enumPar   = AST.unsafeVHDLBasicId "enum"
-    showSpec  = AST.Function showId [AST.IfaceVarDec enumPar enumTM] stringTM
+    parenPar  = AST.unsafeVHDLBasicId "paren"
+    showSpec  = AST.Function showId [AST.IfaceVarDec enumPar enumTM, AST.IfaceVarDec parenPar booleanTM] stringTM
     showExpr  = AST.CaseSm (AST.PrimName $ AST.NSimple enumPar)
                   [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit $ show x] [AST.ReturnSm (Just $ AST.PrimLit $ '"':(elemIds!!x)++['"'])] | x <- [0..(length elemIds) -1]]
             
@@ -684,6 +695,7 @@ mkVectorShow elemTM vectorTM =
   where
     vecPar  = AST.unsafeVHDLBasicId "vec"
     resId   = AST.unsafeVHDLBasicId "res"
+    parenPar = AST.unsafeVHDLBasicId "paren"
     headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM
     -- return vec(0);
     headExpr = AST.ReturnSm (Just (AST.PrimName $ AST.NIndexed (AST.IndexedName 
@@ -710,7 +722,7 @@ mkVectorShow elemTM vectorTM =
                                   AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) 
                                                              AST.:-: AST.PrimLit "1"))
     tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
-    showSpec  = AST.Function showId [AST.IfaceVarDec vecPar vectorTM] stringTM
+    showSpec  = AST.Function showId [AST.IfaceVarDec vecPar vectorTM, AST.IfaceVarDec parenPar booleanTM] stringTM
     doShowId  = AST.unsafeVHDLExtId "doshow"
     doShowDef = AST.SubProgBody doShowSpec [] [doShowRet]
       where doShowSpec = AST.Function doShowId [AST.IfaceVarDec vecPar vectorTM] 
@@ -728,12 +740,12 @@ mkVectorShow elemTM vectorTM =
                          [AST.ReturnSm (Just $ AST.PrimLit "\"\"")],
                AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "1"] 
                          [AST.ReturnSm (Just $ 
-                          genExprFCall showId 
-                               (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) )],
+                          genExprFCall2 showId 
+                               (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar),AST.PrimLit "false") )],
                AST.CaseSmAlt [AST.Others] 
                          [AST.ReturnSm (Just $ 
-                           genExprFCall showId 
-                             (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) AST.:&:
+                           genExprFCall2 showId 
+                             (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar), AST.PrimLit "false") AST.:&:
                            AST.PrimLit "','" AST.:&:
                            genExprFCall doShowId 
                              (genExprFCall (mkVHDLExtId tailId) (AST.PrimName $ AST.NSimple vecPar)) ) ]]
@@ -754,26 +766,27 @@ mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr]
     boolPar     = AST.unsafeVHDLBasicId "b"
     signedPar   = AST.unsafeVHDLBasicId "sint"
     unsignedPar = AST.unsafeVHDLBasicId "uint"
+    parenPar    = AST.unsafeVHDLBasicId "paren"
     -- naturalPar  = AST.unsafeVHDLBasicId "nat"
-    showBitSpec = AST.Function showId [AST.IfaceVarDec bitPar std_logicTM] stringTM
+    showBitSpec = AST.Function showId [AST.IfaceVarDec bitPar std_logicTM, AST.IfaceVarDec parenPar booleanTM] stringTM
     -- if s = '1' then return "'1'" else return "'0'"
     showBitExpr = AST.IfSm (AST.PrimName (AST.NSimple bitPar) AST.:=: AST.PrimLit "'1'")
                         [AST.ReturnSm (Just $ AST.PrimLit "\"High\"")]
                         []
                         (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"Low\"")])
-    showBoolSpec = AST.Function showId [AST.IfaceVarDec boolPar booleanTM] stringTM
+    showBoolSpec = AST.Function showId [AST.IfaceVarDec boolPar booleanTM, AST.IfaceVarDec parenPar booleanTM] stringTM
     -- if b then return "True" else return "False"
     showBoolExpr = AST.IfSm (AST.PrimName (AST.NSimple boolPar))
                         [AST.ReturnSm (Just $ AST.PrimLit "\"True\"")]
                         []
                         (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"False\"")])
-    showSingedSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM] stringTM
+    showSingedSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM, AST.IfaceVarDec parenPar booleanTM] stringTM
     showSignedExpr =  AST.ReturnSm (Just $
                         AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId) 
                         (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [signToInt]) Nothing )
                       where
                         signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple signedPar)
-    showUnsignedSpec =  AST.Function showId [AST.IfaceVarDec unsignedPar unsignedTM] stringTM
+    showUnsignedSpec =  AST.Function showId [AST.IfaceVarDec unsignedPar unsignedTM, AST.IfaceVarDec parenPar booleanTM] stringTM
     showUnsignedExpr =  AST.ReturnSm (Just $
                           AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId) 
                           (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [unsignToInt]) Nothing )
@@ -790,6 +803,11 @@ genExprFCall fName args =
    AST.PrimFCall $ AST.FCall (AST.NSimple fName)  $
              map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [args] 
 
+genExprFCall2 :: AST.VHDLId -> (AST.Expr, AST.Expr) -> AST.Expr
+genExprFCall2 fName (arg1, arg2) = 
+   AST.PrimFCall $ AST.FCall (AST.NSimple fName)  $
+             map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2] 
+
 genExprPCall2 :: AST.VHDLId -> AST.Expr -> AST.Expr -> AST.SeqSm             
 genExprPCall2 entid arg1 arg2 =
         AST.ProcCall (AST.NSimple entid) $