X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=clash%2FCLasH%2FVHDL%2FVHDLTools.hs;h=723f08acb718d968de22940ee1b836c30e1b8183;hb=e82d5210946093b03d9c46b7ffbcb556304e5b0b;hp=6ba4d765179bf118b729744a2e29e07a09500d15;hpb=5594e632ef0aa31926c5533cd67fef8b56b088b1;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git a/clash/CLasH/VHDL/VHDLTools.hs b/clash/CLasH/VHDL/VHDLTools.hs index 6ba4d76..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. @@ -495,7 +506,7 @@ mkTyconTy htype = return $ Just (ty_id, Just $ Left ty_def) (EnumType tycon dcs) -> do let ty_id = mkVHDLExtId tycon - let range = AST.SubTypeRange (AST.PrimLit "0") (AST.PrimLit $ show (length dcs)) + 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) @@ -618,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 @@ -626,14 +638,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 @@ -644,17 +653,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 + 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] - [AST.ReturnSm (Just $ ((genExprFCall showId) . (selectedName adtPar) $ mkVHDLBasicId conLbl) AST.:&: showFields x)] | x <- [0..(length conIds) -1]] + [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.:&: e2) $ - map ((AST.PrimLit "' '" AST.:&:) . (genExprFCall showId) . (selectedName adtPar)) + 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) + 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] @@ -663,7 +682,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]] @@ -680,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 @@ -706,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 @@ -724,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)) ) ]] @@ -750,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 ) @@ -786,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) $