X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=clash%2FCLasH%2FVHDL%2FVHDLTools.hs;h=723f08acb718d968de22940ee1b836c30e1b8183;hb=e82d5210946093b03d9c46b7ffbcb556304e5b0b;hp=639452bcbef3f6a00aa6f1189e88e70e343d4b59;hpb=4583b2b6d86da12e795f199f2951b193efed613f;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git a/clash/CLasH/VHDL/VHDLTools.hs b/clash/CLasH/VHDL/VHDLTools.hs index 639452b..723f08a 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 @@ -206,10 +206,7 @@ dataconToVHDLExpr dc = do varToVHDLId :: CoreSyn.CoreBndr -> AST.VHDLId -varToVHDLId var = mkVHDLExtId (varToString var ++ varToStringUniq var ++ show (lowers $ varToStringUniq var)) - where - lowers :: String -> Int - lowers xs = length [x | x <- xs, Char.isLower x] +varToVHDLId var = mkVHDLExtId $ varToUniqString var -- Creates a VHDL Name from a binder varToVHDLName :: @@ -223,6 +220,14 @@ varToString :: -> String varToString = OccName.occNameString . Name.nameOccName . Var.varName +varToUniqString :: + CoreSyn.CoreBndr + -> String +varToUniqString var = (varToString var ++ varToStringUniq var ++ show (lowers $ varToStringUniq var)) + where + lowers :: String -> Int + lowers xs = length [x | x <- xs, Char.isLower x] + -- Get the string version a Var's unique varToStringUniq :: Var.Var -> String varToStringUniq = show . Var.varUnique @@ -256,12 +261,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. @@ -346,7 +357,8 @@ mkHTypeEither' ty | ty_has_free_tyvars ty = return $ Left $ "\nVHDLTools.mkHType return $ Right $ SizedIType len "Index" -> do bound <- tfp_to_int (ranged_word_bound_ty ty) - return $ Right $ RangedWType bound + -- Upperbound is exclusive, hence the -1 + return $ Right $ RangedWType (bound - 1) otherwise -> mkTyConHType tycon args Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither': Do not know what to do with type: " ++ pprString ty @@ -370,8 +382,8 @@ mkTyConHType tycon args = let real_arg_tyss_nostate = map (filter (\x -> not (isStateType x))) real_arg_tyss elem_htyss_either <- mapM (mapM mkHTypeEither) real_arg_tyss_nostate let (errors, elem_htyss) = unzip (map Either.partitionEithers elem_htyss_either) - case errors of - [] -> case (dcs, concat elem_htyss) of + case (all null errors) of + True -> case (dcs, concat elem_htyss) of -- A single constructor with a single (non-state) field? ([dc], [elem_hty]) -> return $ Right elem_hty -- If we get here, then all of the argument types were state @@ -390,8 +402,8 @@ mkTyConHType tycon args = -- Create the AggrType HType return $ Right $ AggrType name enum_ty_part fieldss -- There were errors in element types - errors -> return $ Left $ - "\nVHDLTools.mkTyConHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n" + False -> return $ Left $ + "\nVHDLTools.mkTyConHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n" ++ (concat $ concat errors) where name = (nameToString (TyCon.tyConName tycon)) @@ -487,14 +499,16 @@ mkTyconTy htype = let enum_decs = Maybe.maybeToList enum_dec_maybe let enum_tys = Maybe.maybeToList enum_ty_maybe let ty_def = AST.TDR $ AST.RecordTypeDef (enum_decs ++ concat elemss) - let tupshow = mkTupleShow (enum_tys ++ concat elem_tyss) ty_id - MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, tupshow) + let aggrshow = case enum_field_maybe of + Nothing -> mkTupleShow (enum_tys ++ concat elem_tyss) ty_id + Just (conLbl, EnumType tycon dcs) -> mkAdtShow conLbl dcs (map (map fst) fieldss) ty_id + MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, aggrshow) return $ Just (ty_id, Just $ Left ty_def) (EnumType tycon dcs) -> do - let elems = map mkVHDLExtId dcs let ty_id = mkVHDLExtId tycon - let ty_def = AST.TDE $ AST.EnumTypeDef elems - let enumShow = mkEnumShow elems ty_id + 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 $ Left ty_def) otherwise -> error $ "\nVHDLTools.mkTyconTy: Called for HType that is neiter a AggrType or EnumType: " ++ show htype @@ -538,7 +552,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)) @@ -546,8 +560,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)) @@ -555,8 +569,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)) @@ -570,8 +584,8 @@ getFields :: getFields htype dc_i = case htype of (AggrType name _ fieldss) | dc_i >= 0 && dc_i < length fieldss -> fieldss!!dc_i - | otherwise -> error $ "Invalid constructor index: " ++ (show dc_i) ++ ". No such constructor in HType: " ++ (show htype) - _ -> error $ "Can't get fields from non-aggregate HType: " ++ show htype + | otherwise -> error $ "VHDLTool.getFields: Invalid constructor index: " ++ (show dc_i) ++ ". No such constructor in HType: " ++ (show htype) + _ -> error $ "VHDLTool.getFields: Can't get fields from non-aggregate HType: " ++ show htype -- Finds the field labels for an aggregation type, as VHDLIds. getFieldLabels :: @@ -581,6 +595,28 @@ getFieldLabels :: -> [AST.VHDLId] -- ^ The labels getFieldLabels htype dc_i = ((map mkVHDLBasicId) . (map fst)) (getFields htype dc_i) +-- Finds the field label for the constructor field, if any. +getConstructorFieldLabel :: + HType + -> Maybe AST.VHDLId +getConstructorFieldLabel (AggrType _ (Just con) _) = + Just $ mkVHDLBasicId (fst con) +getConstructorFieldLabel (AggrType _ Nothing _) = + Nothing +getConstructorFieldLabel htype = + error $ "Can't get constructor field label from non-aggregate HType: " ++ show htype + + +getConstructorIndex :: + HType -> + String -> + Int +getConstructorIndex (EnumType etype cons) dc = case List.elemIndex dc cons of + Just (index) -> index + Nothing -> error $ "VHDLTools.getConstructor: constructor: " ++ show dc ++ " is not part of type: " ++ show etype ++ ", which only has constructors: " ++ show cons +getConstructorIndex htype _ = error $ "Can't get constructor index for non-Enum type: " ++ show htype + + mktydecl :: (AST.VHDLId, Maybe (Either AST.TypeDef AST.SubtypeIn)) -> Maybe AST.PackageDecItem mytydecl (_, Nothing) = Nothing mktydecl (ty_id, Just (Left ty_def)) = Just $ AST.PDITD $ AST.TypeDec ty_id ty_def @@ -593,7 +629,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 @@ -601,25 +638,55 @@ 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 + -> [String] -- Constructors + -> [[String]] -- Fields for every constructor + -> AST.TypeMark + -> AST.SubProgBody +mkAdtShow conLbl conIds elemIdss adtTM = AST.SubProgBody showSpec [] [showExpr] + where + adtPar = AST.unsafeVHDLBasicId "adt" + 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 "\"\"" + else + 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 :: - [AST.VHDLId] + [String] -> 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)) + where + enumPar = AST.unsafeVHDLBasicId "enum" + 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]] + mkVectorShow :: AST.TypeMark -- ^ elemtype @@ -633,6 +700,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 @@ -659,8 +727,8 @@ 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 - doShowId = AST.unsafeVHDLExtId "doshow" + showSpec = AST.Function showId [AST.IfaceVarDec vecPar vectorTM, AST.IfaceVarDec parenPar booleanTM] stringTM + doShowId = AST.unsafeVHDLBasicId "doshow" doShowDef = AST.SubProgBody doShowSpec [] [doShowRet] where doShowSpec = AST.Function doShowId [AST.IfaceVarDec vecPar vectorTM] stringTM @@ -677,12 +745,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)) ) ]] @@ -703,26 +771,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 ) @@ -739,6 +808,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) $