Hack to print OCaml values as pointers or integers (#3)

mshinwell · poechsel · commit 5c412d7bbe62 · 2025-04-22T17:39:10.000+01:00
diff --git a/clang/include/clang/AST/ASTContext.h b/clang/include/clang/AST/ASTContext.h
@@ -1149,6 +1149,7 @@ class ASTContext : public RefCountedBase<ASTContext> {
   CanQualType PseudoObjectTy, ARCUnbridgedCastTy;
   CanQualType ObjCBuiltinIdTy, ObjCBuiltinClassTy, ObjCBuiltinSelTy;
   CanQualType ObjCBuiltinBoolTy;
+  CanQualType OCamlValueTy;
 #define IMAGE_TYPE(ImgType, Id, SingletonId, Access, Suffix) \
   CanQualType SingletonId;
 #include "clang/Basic/OpenCLImageTypes.def"
diff --git a/clang/include/clang/AST/BuiltinTypes.def b/clang/include/clang/AST/BuiltinTypes.def
@@ -226,6 +226,9 @@ FLOATING_TYPE(Ibm128, Ibm128Ty)
 // This is the type of C++0x 'nullptr'.
 BUILTIN_TYPE(NullPtr, NullPtrTy)
 
+// OCaml values
+BUILTIN_TYPE(OCamlValue, OCamlValueTy)
+
 // The primitive Objective C 'id' type.  The user-visible 'id'
 // type is a typedef of an ObjCObjectPointerType to an
 // ObjCObjectType with this as its base.  In fact, this only ever
diff --git a/clang/lib/AST/ASTContext.cpp b/clang/lib/AST/ASTContext.cpp
@@ -1427,6 +1427,8 @@ void ASTContext::InitBuiltinTypes(const TargetInfo &Target,
 
   ObjCSuperType = QualType();
 
+  InitBuiltinType(OCamlValueTy, BuiltinType::OCamlValue);
+
   // void * type
   if (LangOpts.OpenCLGenericAddressSpace) {
     auto Q = VoidTy.getQualifiers();
@@ -2003,6 +2005,10 @@ TypeInfo ASTContext::getTypeInfoImpl(const Type *T) const {
   case Type::Builtin:
     switch (cast<BuiltinType>(T)->getKind()) {
     default: llvm_unreachable("Unknown builtin type!");
+    case BuiltinType::OCamlValue:
+      Width = 64;
+      Align = 64;
+      break;
     case BuiltinType::Void:
       // GCC extension: alignof(void) = 8 bits.
       Width = 0;
@@ -3359,6 +3365,7 @@ static void encodeTypeForFunctionPointerAuth(const ASTContext &Ctx,
       llvm_unreachable("should never get here");
     case BuiltinType::AMDGPUBufferRsrc:
     case BuiltinType::WasmExternRef:
+    case BuiltinType::OCamlValue:
 #define RVV_TYPE(Name, Id, SingletonId) case BuiltinType::Id:
 #include "clang/Basic/RISCVVTypes.def"
       llvm_unreachable("not yet implemented");
@@ -8509,6 +8516,9 @@ static char getObjCEncodingForPrimitiveType(const ASTContext *C,
         return ' ';
       }
 
+    case BuiltinType::OCamlValue:
+      llvm_unreachable("@encoding OCaml value type");
+
     case BuiltinType::ObjCId:
     case BuiltinType::ObjCClass:
     case BuiltinType::ObjCSel:
diff --git a/clang/lib/AST/ExprConstant.cpp b/clang/lib/AST/ExprConstant.cpp
@@ -11849,6 +11849,7 @@ GCCTypeClass EvaluateBuiltinClassifyType(QualType T,
 
     case BuiltinType::NullPtr:
 
+    case BuiltinType::OCamlValue:
     case BuiltinType::ObjCId:
     case BuiltinType::ObjCClass:
     case BuiltinType::ObjCSel:
diff --git a/clang/lib/AST/ItaniumMangle.cpp b/clang/lib/AST/ItaniumMangle.cpp
@@ -3329,6 +3329,9 @@ void CXXNameMangler::mangleType(const BuiltinType *T) {
     Out << "Dn";
     break;
 
+  case BuiltinType::OCamlValue:
+    llvm_unreachable("mangling an OCaml value type");
+
 #define BUILTIN_TYPE(Id, SingletonId)
 #define PLACEHOLDER_TYPE(Id, SingletonId) \
   case BuiltinType::Id:
diff --git a/clang/lib/AST/MicrosoftMangle.cpp b/clang/lib/AST/MicrosoftMangle.cpp
@@ -2635,6 +2635,9 @@ void MicrosoftCXXNameMangler::mangleType(const BuiltinType *T, Qualifiers,
   case BuiltinType::Dependent:
     llvm_unreachable("placeholder types shouldn't get to name mangling");
 
+  case BuiltinType::OCamlValue:
+    llvm_unreachable("cannot mangle OCaml value types");
+
   case BuiltinType::ObjCId:
     mangleArtificialTagType(TagTypeKind::Struct, "objc_object");
     break;
diff --git a/clang/lib/AST/NSAPI.cpp b/clang/lib/AST/NSAPI.cpp
@@ -429,6 +429,7 @@ NSAPI::getNSNumberFactoryMethodKind(QualType T) const {
   case BuiltinType::Float128:
   case BuiltinType::Ibm128:
   case BuiltinType::NullPtr:
+  case BuiltinType::OCamlValue:
   case BuiltinType::ObjCClass:
   case BuiltinType::ObjCId:
   case BuiltinType::ObjCSel:
diff --git a/clang/lib/AST/Type.cpp b/clang/lib/AST/Type.cpp
@@ -3402,6 +3402,8 @@ StringRef BuiltinType::getName(const PrintingPolicy &Policy) const {
     return "<ARC unbridged cast type>";
   case BuiltinFn:
     return "<builtin fn type>";
+  case OCamlValue:
+    return "ocaml_value";
   case ObjCId:
     return "id";
   case ObjCClass:
@@ -4760,6 +4762,7 @@ bool Type::canHaveNullability(bool ResultIfUnknown) const {
       return ResultIfUnknown;
 
     case BuiltinType::Void:
+    case BuiltinType::OCamlValue:
     case BuiltinType::ObjCId:
     case BuiltinType::ObjCClass:
     case BuiltinType::ObjCSel:
diff --git a/clang/lib/AST/TypeLoc.cpp b/clang/lib/AST/TypeLoc.cpp
@@ -404,6 +404,7 @@ TypeSpecifierType BuiltinTypeLoc::getWrittenTypeSpec() const {
   case BuiltinType::UnknownAny:
   case BuiltinType::ARCUnbridgedCast:
   case BuiltinType::PseudoObject:
+  case BuiltinType::OCamlValue:
   case BuiltinType::ObjCId:
   case BuiltinType::ObjCClass:
   case BuiltinType::ObjCSel:
diff --git a/clang/lib/CodeGen/CGDebugInfo.cpp b/clang/lib/CodeGen/CGDebugInfo.cpp
@@ -903,6 +903,7 @@ llvm::DIType *CGDebugInfo::CreateType(const BuiltinType *BT) {
   case BuiltinType::Long:
   case BuiltinType::WChar_S:
   case BuiltinType::LongLong:
+  case BuiltinType::OCamlValue:
     Encoding = llvm::dwarf::DW_ATE_signed;
     break;
   case BuiltinType::Bool:
diff --git a/clang/lib/CodeGen/CodeGenTypes.cpp b/clang/lib/CodeGen/CodeGenTypes.cpp
@@ -446,6 +446,7 @@ llvm::Type *CodeGenTypes::ConvertType(QualType T) {
     case BuiltinType::SatUShortFract:
     case BuiltinType::SatUFract:
     case BuiltinType::SatULongFract:
+    case BuiltinType::OCamlValue:
       ResultType = llvm::IntegerType::get(getLLVMContext(),
                                  static_cast<unsigned>(Context.getTypeSize(T)));
       break;
diff --git a/clang/lib/CodeGen/ItaniumCXXABI.cpp b/clang/lib/CodeGen/ItaniumCXXABI.cpp
@@ -3658,6 +3658,7 @@ static bool TypeInfoIsInStandardLibrary(const BuiltinType *Ty) {
     case BuiltinType::SatUFract:
     case BuiltinType::SatULongFract:
     case BuiltinType::BFloat16:
+    case BuiltinType::OCamlValue:
       return false;
 
     case BuiltinType::Dependent:
diff --git a/clang/lib/Index/USRGeneration.cpp b/clang/lib/Index/USRGeneration.cpp
@@ -843,6 +843,8 @@ void USRGenerator::VisitType(QualType T) {
           Out << 'O'; break;
         case BuiltinType::ObjCSel:
           Out << 'e'; break;
+        case BuiltinType::OCamlValue:
+          Out << "@BT@OCamlValue"; break;
 #define BUILTIN_TYPE(Id, SingletonId)
 #define PLACEHOLDER_TYPE(Id, SingletonId) case BuiltinType::Id:
 #include "clang/AST/BuiltinTypes.def"
diff --git a/clang/lib/Serialization/ASTCommon.cpp b/clang/lib/Serialization/ASTCommon.cpp
@@ -281,6 +281,8 @@ serialization::TypeIdxFromBuiltin(const BuiltinType *BT) {
   case BuiltinType::BFloat16:
     ID = PREDEF_TYPE_BFLOAT16_ID;
     break;
+  case BuiltinType::OCamlValue:
+    llvm_unreachable("not implemented");
   }
 
   return TypeIdx(0, ID);
diff --git a/clang/tools/libclang/CIndex.cpp b/clang/tools/libclang/CIndex.cpp
@@ -1625,6 +1625,7 @@ bool CursorVisitor::VisitBuiltinTypeLoc(BuiltinTypeLoc TL) {
   case BuiltinType::Void:
   case BuiltinType::NullPtr:
   case BuiltinType::Dependent:
+  case BuiltinType::OCamlValue:
 #define IMAGE_TYPE(ImgType, Id, SingletonId, Access, Suffix)                   \
   case BuiltinType::Id:
 #include "clang/Basic/OpenCLImageTypes.def"
diff --git a/lldb/include/lldb/lldb-enumerations.h b/lldb/include/lldb/lldb-enumerations.h
@@ -200,6 +200,7 @@ enum Format {
   eFormatInstruction, ///< Disassemble an opcode
   eFormatVoid,        ///< Do not print this
   eFormatUnicode8,
+  eFormatOCamlValue,
   kNumFormats
 };
 
@@ -826,6 +827,7 @@ enum BasicType {
   eBasicTypeObjCClass,
   eBasicTypeObjCSel,
   eBasicTypeNullPtr,
+  eBasicTypeOCamlValue,
   eBasicTypeOther
 };
 
diff --git a/lldb/source/Commands/CommandObjectMemory.cpp b/lldb/source/Commands/CommandObjectMemory.cpp
@@ -1349,6 +1349,7 @@ class CommandObjectMemoryWrite : public CommandObjectParsed {
       case eFormatVectorOfFloat32:
       case eFormatVectorOfFloat64:
       case eFormatVectorOfUInt128:
+      case eFormatOCamlValue:
       case eFormatOSType:
       case eFormatComplexInteger:
       case eFormatAddressInfo:
diff --git a/lldb/source/Core/DumpDataExtractor.cpp b/lldb/source/Core/DumpDataExtractor.cpp
diff --git a/lldb/source/DataFormatters/FormatManager.cpp b/lldb/source/DataFormatters/FormatManager.cpp
diff --git a/lldb/source/Plugins/Process/gdb-remote/GDBRemoteCommunicationServerLLGS.cpp b/lldb/source/Plugins/Process/gdb-remote/GDBRemoteCommunicationServerLLGS.cpp
diff --git a/lldb/source/Plugins/TypeSystem/Clang/TypeSystemClang.cpp b/lldb/source/Plugins/TypeSystem/Clang/TypeSystemClang.cpp
