Skip to content

Instantly share code, notes, and snippets.

@martijnbastiaan

martijnbastiaan/gist:b13b9bfece9e4f96ce56ee883b816b47

Created December 18, 2019 09:24
Show Gist options
  • Save martijnbastiaan/b13b9bfece9e4f96ce56ee883b816b47 to your computer and use it in GitHub Desktop.
Save martijnbastiaan/b13b9bfece9e4f96ce56ee883b816b47 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
gistfile1.diff
diff --git a/clash-ghc/src-ghc/Clash/GHC/Evaluator.hs b/clash-ghc/src-ghc/Clash/GHC/Evaluator.hs
index e0d7cfe2..c0de76a6 100644
--- a/clash-ghc/src-ghc/Clash/GHC/Evaluator.hs
+++ b/clash-ghc/src-ghc/Clash/GHC/Evaluator.hs
@@ -30,12 +30,14 @@ import Data.Bits
import Data.Char (chr,ord)
import qualified Data.Either as Either
import qualified Data.IntMap as IntMap
-import Data.Maybe (mapMaybe, catMaybes)
+import Data.Maybe
+ (fromMaybe, mapMaybe, catMaybes)
import qualified Data.List as List
import qualified Data.Primitive.ByteArray as ByteArray
import Data.Proxy (Proxy)
import Data.Reflection (reifyNat)
import Data.Text (Text)
+import qualified Data.Text as Text
import qualified Data.Vector.Primitive as Vector
import Debug.Trace (trace)
import GHC.Float
@@ -53,7 +55,7 @@ import GHC.Word
import System.IO.Unsafe (unsafeDupablePerformIO)
import BasicTypes (Boxity (..))
-import Name (getSrcSpan)
+import Name (getSrcSpan, nameOccName, occNameString)
import PrelNames
(typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatSubTyFamNameKey)
import SrcLoc (wiredInSrcSpan)
@@ -82,7 +84,7 @@ import Clash.Core.Util
(mkApps,mkRTree,mkVec,piResultTys,tyNatSize,dataConInstArgTys,primCo,
undefinedTm)
import Clash.Core.Var (mkLocalId, mkTyVar)
-import Clash.GHC.GHC2Core (qualifiedNameString)
+import Clash.GHC.GHC2Core (modNameM)
import Clash.Rewrite.Util (mkSelectorCase)
import Clash.Unique (lookupUniqMap)
import Clash.Util
@@ -4275,7 +4277,9 @@ ghcTyconToTyConName
ghcTyconToTyConName tc =
Name User n' (getKey (TyCon.tyConUnique tc)) (getSrcSpan n)
where
- n' = qualifiedNameString n
+ n' = fromMaybe "_INTERNAL_" (modNameM n) `Text.append`
+ ('.' `Text.cons` Text.pack occName)
+ occName = occNameString $ nameOccName n
n = TyCon.tyConName tc
svoid :: (State# RealWorld -> State# RealWorld) -> IO ()
diff --git a/clash-ghc/src-ghc/Clash/GHC/GHC2Core.hs b/clash-ghc/src-ghc/Clash/GHC/GHC2Core.hs
index 07df5945..612de709 100644
--- a/clash-ghc/src-ghc/Clash/GHC/GHC2Core.hs
+++ b/clash-ghc/src-ghc/Clash/GHC/GHC2Core.hs
@@ -22,8 +22,9 @@ module Clash.GHC.GHC2Core
, coreToTerm
, coreToId
, coreToName
- , qualifiedNameStringM
+ , modNameM
, qualifiedNameString
+ , qualifiedNameString'
, makeAllTyCons
, emptyGHC2CoreState
)
@@ -37,13 +38,14 @@ import qualified Data.ByteString.Char8 as Char8
import Data.Hashable (Hashable (..))
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
-import Data.Maybe (catMaybes,listToMaybe)
+import Data.Maybe (catMaybes,fromMaybe,listToMaybe)
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup
#endif
import Data.Text (Text, isInfixOf,pack)
import qualified Data.Text as Text
import Data.Text.Encoding (decodeUtf8)
+import qualified Data.Traversable as T
-- GHC API
import CoAxiom (CoAxiom (co_ax_branches), CoAxBranch (cab_lhs,cab_rhs),
@@ -121,8 +123,8 @@ instance Hashable Name where
data GHC2CoreState
= GHC2CoreState
- { _tyConMap :: !(C.UniqMap TyCon)
- , _nameMap :: !(HashMap Name Text)
+ { _tyConMap :: C.UniqMap TyCon
+ , _nameMap :: HashMap Name Text
}
makeLenses ''GHC2CoreState
@@ -156,7 +158,7 @@ makeAllTyCons hm fiEnvs = go hm hm
| C.nullUniqMap (new ^. tyConMap) = C.emptyUniqMap
| otherwise = tcm `C.unionUniqMap` tcm'
where
- (tcm,old', _) = RWS.runRWS (mapM (makeTyCon fiEnvs) (new ^. tyConMap)) noSrcSpan old
+ (tcm,old', _) = RWS.runRWS (T.mapM (makeTyCon fiEnvs) (new ^. tyConMap)) noSrcSpan old
tcm' = go old' (old' & tyConMap %~ (`C.differenceUniqMap` (old ^. tyConMap)))
makeTyCon :: FamInstEnvs
@@ -175,7 +177,7 @@ makeTyCon fiEnvs tc = tycon
tcArity = tyConArity tc
mkAlgTyCon = do
- tcName <- coreToName tyConName tyConUnique tc
+ tcName <- coreToName tyConName tyConUnique qualifiedNameString tc
tcKind <- coreToType (tyConKind tc)
tcRhsM <- makeAlgTyConRhs $ algTyConRhs tc
case tcRhsM of
@@ -192,7 +194,7 @@ makeTyCon fiEnvs tc = tycon
Nothing -> return (C.PrimTyCon (C.nameUniq tcName) tcName tcKind tcArity)
mkFunTyCon = do
- tcName <- coreToName tyConName tyConUnique tc
+ tcName <- coreToName tyConName tyConUnique qualifiedNameString tc
tcKind <- coreToType (tyConKind tc)
substs <- case isClosedSynFamilyTyConWithAxiom_maybe tc of
Nothing -> let instances = familyInstances fiEnvs tc
@@ -211,7 +213,7 @@ makeTyCon fiEnvs tc = tycon
}
mkTupleTyCon = do
- tcName <- coreToName tyConName tyConUnique tc
+ tcName <- coreToName tyConName tyConUnique qualifiedNameString tc
tcKind <- coreToType (tyConKind tc)
tcDc <- fmap (C.DataTyCon . (:[])) . coreToDataCon . head . tyConDataCons $ tc
return
@@ -225,7 +227,7 @@ makeTyCon fiEnvs tc = tycon
}
mkPrimTyCon = do
- tcName <- coreToName tyConName tyConUnique tc
+ tcName <- coreToName tyConName tyConUnique qualifiedNameString tc
tcKind <- coreToType (tyConKind tc)
return
C.PrimTyCon
@@ -236,14 +238,14 @@ makeTyCon fiEnvs tc = tycon
}
mkSuperKindTyCon = do
- tcName <- coreToName tyConName tyConUnique tc
+ tcName <- coreToName tyConName tyConUnique qualifiedNameString tc
return C.SuperKindTyCon
{ C.tyConUniq = C.nameUniq tcName
, C.tyConName = tcName
}
mkVoidTyCon = do
- tcName <- coreToName tyConName tyConUnique tc
+ tcName <- coreToName tyConName tyConUnique qualifiedNameString tc
tcKind <- coreToType (tyConKind tc)
return (C.PrimTyCon (C.nameUniq tcName) tcName tcKind tcArity)
@@ -259,12 +261,12 @@ makeAlgTyConRhs algTcRhs = case algTcRhs of
#if MIN_VERSION_ghc(8,6,0)
DataTyCon dcs _ _ -> Just <$> C.DataTyCon <$> mapM coreToDataCon dcs
#else
- DataTyCon dcs _ -> Just . C.DataTyCon <$> mapM coreToDataCon dcs
+ DataTyCon dcs _ -> Just <$> C.DataTyCon <$> mapM coreToDataCon dcs
#endif
#if MIN_VERSION_ghc(8,6,0)
- SumTyCon dcs _ -> Just . C.DataTyCon <$> mapM coreToDataCon dcs
+ SumTyCon dcs _ -> Just <$> C.DataTyCon <$> mapM coreToDataCon dcs
#else
- SumTyCon dcs -> Just . C.DataTyCon <$> mapM coreToDataCon dcs
+ SumTyCon dcs -> Just <$> C.DataTyCon <$> mapM coreToDataCon dcs
#endif
NewTyCon dc _ (rhsTvs,rhsEtad) _ -> Just <$> (C.NewTyCon <$> coreToDataCon dc
<*> ((,) <$> mapM coreToTyVar rhsTvs
@@ -284,7 +286,7 @@ coreToTerm primMap unlocs = term
term :: CoreExpr -> C2C C.Term
term e
| (Var x,args) <- collectArgs e
- , let (nm, _) = RWS.evalRWS (qualifiedNameStringM (varName x))
+ , let (nm, _) = RWS.evalRWS (qualifiedNameString (varName x))
noSrcSpan
emptyGHC2CoreState
= go nm args
@@ -419,7 +421,7 @@ coreToTerm primMap unlocs = term
lookupPrim nm = extractPrim <$> HashMap.lookup nm primMap
var x = do
- xPrim <- coreToVar x
+ xPrim <- if isGlobalId x then coreToPrimVar x else coreToVar x
let xNameS = C.nameOcc xPrim
xType <- coreToType (varType x)
case isDataConId_maybe x of
@@ -543,7 +545,7 @@ addUsefullR x m =
isIntegerTy :: Type -> C2C Bool
isIntegerTy (TyConApp tc []) = do
- tcNm <- qualifiedNameStringM (tyConName tc)
+ tcNm <- qualifiedNameString (tyConName tc)
return (tcNm == "GHC.Integer.Type.Integer")
isIntegerTy _ = return False
@@ -569,7 +571,7 @@ hasPrimCo co@(AxiomInstCo _ _ coers) = do
return (listToMaybe tcs)
where
isPrimTc (TyConApp tc _) = do
- tcNm <- qualifiedNameStringM (tyConName tc)
+ tcNm <- qualifiedNameString (tyConName tc)
return (tcNm `elem` ["Clash.Sized.Internal.BitVector.Bit"
,"Clash.Sized.Internal.BitVector.BitVector"
,"Clash.Sized.Internal.Index.Index"
@@ -612,7 +614,7 @@ coreToDataCon dc = do
let decLabel = decodeUtf8 . fastStringToByteString . flLabel
let fLabels = map decLabel (dataConFieldLabels dc)
- nm <- coreToName dataConName getUnique dc
+ nm <- coreToName dataConName getUnique qualifiedNameString dc
uTvs <- mapM coreToTyVar (dataConUnivTyVars dc)
#if MIN_VERSION_ghc(8,8,0)
eTvs <- mapM coreToTyVar (dataConExTyCoVars dc)
@@ -634,7 +636,7 @@ typeConstructorToString
:: TyCon
-> C2C String
typeConstructorToString constructor =
- Text.unpack . C.nameOcc <$> coreToName tyConName tyConUnique constructor
+ Text.unpack . C.nameOcc <$> coreToName tyConName tyConUnique qualifiedNameString constructor
_ATTR_NAME :: String
_ATTR_NAME = "Clash.Annotations.SynthesisAttributes.Attr"
@@ -712,7 +714,7 @@ coreToAttrs' [annotationType, realType, attributes] = allAttrs
let result | name' == "GHC.Types.[]" && name'' == _ATTR_NAME =
-- List of attributes
- mapM coreToAttr (listTypeToListOfTypes attributes)
+ sequence $ map coreToAttr (listTypeToListOfTypes attributes)
| name' == "GHC.Types.[]" =
-- List, but unknown types
error $ $(curLoc) ++ unwords [ "Annotate expects an"
@@ -800,9 +802,9 @@ coreToType' (TyConApp tc args)
synTy' = substTy substs' synTy
foldl C.AppTy <$> coreToType synTy' <*> mapM coreToType remArgs
_ -> do
- tcName <- coreToName tyConName tyConUnique tc
- tyConMap %= C.extendUniqMap tcName tc
- C.mkTyConApp tcName <$> mapM coreToType args
+ tcName <- coreToName tyConName tyConUnique qualifiedNameString tc
+ tyConMap %= (C.extendUniqMap tcName tc)
+ C.mkTyConApp <$> (pure tcName) <*> mapM coreToType args
#if MIN_VERSION_ghc(8,8,0)
coreToType' (ForAllTy (Bndr tv _) ty) = C.ForAllTy <$> coreToTyVar tv <*> coreToType ty
#else
@@ -826,43 +828,69 @@ coreToTyVar tv =
coreToId :: Id
-> C2C C.Id
-coreToId i =
+coreToId i = do
C.mkId <$> coreToType (varType i) <*> pure scope <*> coreToVar i
where
scope = if isGlobalId i then C.GlobalId else C.LocalId
coreToVar :: Var
-> C2C (C.Name a)
-coreToVar = coreToName varName varUnique
+coreToVar = coreToName varName varUnique qualifiedNameStringM
+
+coreToPrimVar :: Var
+ -> C2C (C.Name C.Term)
+coreToPrimVar = coreToName varName varUnique qualifiedNameString
coreToName
:: (b -> Name)
-> (b -> Unique)
+ -> (Name -> C2C Text)
-> b
-> C2C (C.Name a)
-coreToName toName toUnique v = do
- ns <- qualifiedNameStringM (toName v)
+coreToName toName toUnique toString v = do
+ ns <- toString (toName v)
let key = getKey (toUnique v)
locI = getSrcSpan (toName v)
- sort = if ns == "ds" || Text.isPrefixOf "$" ns then C.System else C.User
+ sort | ns == "ds" || Text.isPrefixOf "$" ns
+ = C.System
+ | otherwise
+ = C.User
locR <- RWS.ask
let loc = if isGoodSrcSpan locI then locI else locR
return (C.Name sort ns key loc)
-qualifiedNameString
+qualifiedNameString'
:: Name
-> Text
+qualifiedNameString' n =
+ fromMaybe "_INTERNAL_" (modNameM n) `Text.append` ('.' `Text.cons` occName)
+ where
+ occName = pack (occNameString (nameOccName n))
+
+qualifiedNameString
+ :: Name
+ -> C2C Text
qualifiedNameString n =
- Text.append modName $ Text.cons '.' occName
+ makeCached n nameMap $
+ return (fromMaybe "_INTERNAL_" (modNameM n) `Text.append` ('.' `Text.cons` occName))
where
- modName = maybe "_INTERNAL_" (Text.pack . moduleNameString . moduleName) (nameModule_maybe n)
- occName = Text.pack (occNameString (nameOccName n))
+ occName = pack (occNameString (nameOccName n))
qualifiedNameStringM
:: Name
-> C2C Text
qualifiedNameStringM n =
- makeCached n nameMap . return $ qualifiedNameString n
+ makeCached n nameMap $
+ return (maybe occName (\modName -> modName `Text.append` ('.' `Text.cons` occName)) (modNameM n))
+ where
+ occName = pack (occNameString (nameOccName n))
+
+modNameM :: Name
+ -> Maybe Text
+modNameM n = do
+ module_ <- nameModule_maybe n
+ let moduleNm = moduleName module_
+ return (pack (moduleNameString moduleNm))
-- | Given the type:
--
diff --git a/clash-ghc/src-ghc/Clash/GHC/GenerateBindings.hs b/clash-ghc/src-ghc/Clash/GHC/GenerateBindings.hs
index 96b628d7..d6fe6201 100644
--- a/clash-ghc/src-ghc/Clash/GHC/GenerateBindings.hs
+++ b/clash-ghc/src-ghc/Clash/GHC/GenerateBindings.hs
@@ -58,7 +58,7 @@ import Clash.Driver (compilePrimitive)
import Clash.Driver.Types (BindingMap)
import Clash.GHC.GHC2Core
(C2C, GHC2CoreState, tyConMap, coreToId, coreToName, coreToTerm,
- makeAllTyCons, qualifiedNameStringM, emptyGHC2CoreState)
+ makeAllTyCons, qualifiedNameString, emptyGHC2CoreState)
import Clash.GHC.LoadModules (ghcLibDir, loadModules)
import Clash.Netlist.BlackBox.Util (usedArguments)
import Clash.Primitives.Types
@@ -123,7 +123,7 @@ generateBindings useColor primDirs importDirs dbs hdl modName dflagsM = do
allBindings = bindingsMap `unionVarEnv` clsMap
topEntities' =
(\m -> fst (RWS.evalRWS m GHC.noSrcSpan tcMap')) $ mapM (\(topEnt,annM,benchM) -> do
- topEnt' <- coreToName GHC.varName GHC.varUnique topEnt
+ topEnt' <- coreToName GHC.varName GHC.varUnique qualifiedNameString topEnt
benchM' <- traverse coreToId benchM
return (topEnt',annM,benchM')) topEntities
topEntities'' = map (\(topEnt,annM,benchM) -> case lookupUniqMap topEnt allBindings of
@@ -197,7 +197,7 @@ mkBindings primMap bindings clsOps unlocatable = do
-- * isn't using all its arguments
checkPrimitive :: CompiledPrimMap -> GHC.CoreBndr -> C2C ()
checkPrimitive primMap v = do
- nm <- qualifiedNameStringM (GHC.varName v)
+ nm <- qualifiedNameString (GHC.varName v)
case HashMap.lookup nm primMap of
Just (extractPrim -> Just (BlackBox _ _ _ _ _ _ _ _ _ inc r ri templ)) -> do
let
@@ -212,7 +212,7 @@ checkPrimitive primMap v = do
GHC.UnhelpfulLoc _ -> ""
GHC.RealSrcLoc l -> showPpr l ++ ": "
warnIf cond msg = traceIf cond ("\n"++loc++"Warning: "++msg) return ()
- qName <- Text.unpack <$> qualifiedNameStringM (GHC.varName v)
+ qName <- Text.unpack <$> qualifiedNameString (GHC.varName v)
let primStr = "primitive " ++ qName ++ " "
let usedArgs = concat [ maybe [] usedArguments r
, maybe [] usedArguments ri
@@ -278,7 +278,8 @@ mkTupTyCons tcMap = (tcMap'',tupTcCache)
tupTyCons = GHC.boolTyCon : GHC.promotedTrueDataCon : GHC.promotedFalseDataCon
: map (GHC.tupleTyCon GHC.Boxed) [2..62]
(tcNames,tcMap',_) =
- RWS.runRWS (mapM (\tc -> coreToName GHC.tyConName GHC.tyConUnique tc) tupTyCons)
+ RWS.runRWS (mapM (\tc -> coreToName GHC.tyConName GHC.tyConUnique
+ qualifiedNameString tc) tupTyCons)
GHC.noSrcSpan
tcMap
tupTcCache = IMS.fromList (zip [2..62] (drop 3 tcNames))
diff --git a/clash-ghc/src-ghc/Clash/GHC/LoadInterfaceFiles.hs b/clash-ghc/src-ghc/Clash/GHC/LoadInterfaceFiles.hs
index 9a5e98cd..6c3084de 100644
--- a/clash-ghc/src-ghc/Clash/GHC/LoadInterfaceFiles.hs
+++ b/clash-ghc/src-ghc/Clash/GHC/LoadInterfaceFiles.hs
@@ -63,7 +63,7 @@ import Clash.Annotations.Primitive
import Clash.Annotations.BitRepresentation (DataReprAnn)
import Clash.Primitives.Types (UnresolvedPrimitive, name)
import Clash.Primitives.Util (decodeOrErr)
-import Clash.GHC.GHC2Core (qualifiedNameString)
+import Clash.GHC.GHC2Core (qualifiedNameString')
import Clash.Util (curLoc, traceIf)
runIfl :: GHC.GhcMonad m => GHC.Module -> TcRnTypes.IfL a -> m a
@@ -245,7 +245,7 @@ unresolvedPrimitives hdl targetPrim =
Annotations.ModuleTarget _ ->
liftIO (decodeOrErr contentOrFp <$> BL.readFile contentOrFp)
Annotations.NamedTarget targetName0 ->
- let targetName1 = Text.unpack (qualifiedNameString targetName0)
+ let targetName1 = Text.unpack (qualifiedNameString' targetName0)
prim =
case decodeOrErr targetName1 (BLU.fromString contentOrFp) of
[] -> error $ "No annotations found for " ++ targetName1
diff --git a/clash-ghc/src-ghc/Clash/GHC/LoadModules.hs b/clash-ghc/src-ghc/Clash/GHC/LoadModules.hs
index 8432fc62..525d8281 100644
--- a/clash-ghc/src-ghc/Clash/GHC/LoadModules.hs
+++ b/clash-ghc/src-ghc/Clash/GHC/LoadModules.hs
@@ -91,7 +91,7 @@ import Util (OverridingBool)
import qualified Var
-- Internal Modules
-import Clash.GHC.GHC2Core (qualifiedNameString)
+import Clash.GHC.GHC2Core (modNameM, qualifiedNameString')
import Clash.GHC.LoadInterfaceFiles (loadExternalExprs, unresolvedPrimitives)
import Clash.GHCi.Common (checkMonoLocalBindsMod)
import Clash.Util (curLoc, noSrcSpan, reportTimeDiff
@@ -445,7 +445,7 @@ findPrimitiveGuardAnnotations
findPrimitiveGuardAnnotations bndrs = do
anns0 <- findNamedAnnotations bndrs
let anns1 = errOnDuplicateAnnotations "PrimitiveGuard" bndrs anns0
- pure (map (first (qualifiedNameString . Var.varName)) anns1)
+ pure (map (first (qualifiedNameString' . Var.varName)) anns1)
-- | Find annotations of type @DataReprAnn@ and convert them to @DataRepr'@
findCustomReprAnnotations
@@ -492,7 +492,8 @@ findTestBenchAnnotations bndrs = do
eqNm thNm bndr = Text.pack (show thNm) == qualNm
where
bndrNm = Var.varName bndr
- qualNm = qualifiedNameString bndrNm
+ qualNm = maybe occName (\modName -> modName `Text.append` ('.' `Text.cons` occName)) (modNameM bndrNm)
+ occName = Text.pack (OccName.occNameString (Name.nameOccName bndrNm))
-- | Find primitive annotations bound to given binders, or annotations made
-- in modules of those binders.
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment