ocaml raw type formatted as a sequence of bytes

spiessimon · spiessimon · commit 4d29c58cd4b3 · 2025-08-22T18:47:41.000+01:00
diff --git a/clang/include/clang/AST/ASTContext.h b/clang/include/clang/AST/ASTContext.h
@@ -239,6 +239,7 @@ class ASTContext : public RefCountedBase<ASTContext> {
   mutable llvm::FoldingSet<PipeType> PipeTypes;
   mutable llvm::FoldingSet<BitIntType> BitIntTypes;
   mutable llvm::FoldingSet<DependentBitIntType> DependentBitIntTypes;
+  mutable llvm::FoldingSet<OCamlRawType> OCamlRawTypes;
   llvm::FoldingSet<BTFTagAttributedType> BTFTagAttributedTypes;
 
   mutable llvm::FoldingSet<QualifiedTemplateName> QualifiedTemplateNames;
@@ -1368,6 +1369,9 @@ class ASTContext : public RefCountedBase<ASTContext> {
   /// and bit count.
   QualType getDependentBitIntType(bool Unsigned, Expr *BitsExpr) const;
 
+  /// Return an OCaml raw data type with the specified bit count.
+  QualType getOCamlRawType(unsigned NumBits) const;
+
   /// Gets the struct used to keep track of the extended descriptor for
   /// pointer to blocks.
   QualType getBlockDescriptorExtendedType() const;
diff --git a/clang/include/clang/AST/RecursiveASTVisitor.h b/clang/include/clang/AST/RecursiveASTVisitor.h
@@ -1156,6 +1156,7 @@ DEF_TRAVERSE_TYPE(PipeType, { TRY_TO(TraverseType(T->getElementType())); })
 DEF_TRAVERSE_TYPE(BitIntType, {})
 DEF_TRAVERSE_TYPE(DependentBitIntType,
                   { TRY_TO(TraverseStmt(T->getNumBitsExpr())); })
+DEF_TRAVERSE_TYPE(OCamlRawType, {})
 
 #undef DEF_TRAVERSE_TYPE
 
@@ -1456,6 +1457,7 @@ DEF_TRAVERSE_TYPELOC(BitIntType, {})
 DEF_TRAVERSE_TYPELOC(DependentBitIntType, {
   TRY_TO(TraverseStmt(TL.getTypePtr()->getNumBitsExpr()));
 })
+DEF_TRAVERSE_TYPELOC(OCamlRawType, {})
 
 #undef DEF_TRAVERSE_TYPELOC
 
diff --git a/clang/include/clang/AST/Type.h b/clang/include/clang/AST/Type.h
@@ -6541,6 +6541,33 @@ class BitIntType final : public Type, public llvm::FoldingSetNode {
   static bool classof(const Type *T) { return T->getTypeClass() == BitInt; }
 };
 
+/// OCaml raw data type with specified bit width for LLDB debugging
+class OCamlRawType final : public Type, public llvm::FoldingSetNode {
+  friend class ASTContext;
+  unsigned NumBits : 24;
+
+protected:
+  OCamlRawType(unsigned NumBits);
+
+public:
+  unsigned getNumBits() const { return NumBits; }
+  
+  bool isSugared() const { return false; }
+  QualType desugar() const { return QualType(this, 0); }
+  
+  void Profile(llvm::FoldingSetNodeID &ID) {
+    Profile(ID, getNumBits());
+  }
+  
+  static void Profile(llvm::FoldingSetNodeID &ID, unsigned NumBits) {
+    ID.AddInteger(NumBits);
+  }
+  
+  static bool classof(const Type *T) { 
+    return T->getTypeClass() == OCamlRaw; 
+  }
+};
+
 class DependentBitIntType final : public Type, public llvm::FoldingSetNode {
   friend class ASTContext;
   const ASTContext &Context;
diff --git a/clang/include/clang/AST/TypeLoc.h b/clang/include/clang/AST/TypeLoc.h
@@ -2655,6 +2655,10 @@ class DependentBitIntTypeLoc final
     : public InheritingConcreteTypeLoc<TypeSpecTypeLoc, DependentBitIntTypeLoc,
                                        DependentBitIntType> {};
 
+class OCamlRawTypeLoc final
+    : public InheritingConcreteTypeLoc<TypeSpecTypeLoc, OCamlRawTypeLoc,
+                                       OCamlRawType> {};
+
 class ObjCProtocolLoc {
   ObjCProtocolDecl *Protocol = nullptr;
   SourceLocation Loc = SourceLocation();
diff --git a/clang/include/clang/AST/TypeProperties.td b/clang/include/clang/AST/TypeProperties.td
@@ -946,3 +946,13 @@ let Class = DependentBitIntType in {
     return ctx.getDependentBitIntType(isUnsigned, numBitsExpr);
   }]>;
 }
+
+let Class = OCamlRawType in {
+  def : Property<"numBits", UInt32> {
+    let Read = [{ node->getNumBits() }];
+  }
+
+  def : Creator<[{
+    return ctx.getOCamlRawType(numBits);
+  }]>;
+}
diff --git a/clang/include/clang/Basic/TypeNodes.td b/clang/include/clang/Basic/TypeNodes.td
@@ -111,3 +111,4 @@ def PipeType : TypeNode<Type>;
 def AtomicType : TypeNode<Type>;
 def BitIntType : TypeNode<Type>;
 def DependentBitIntType : TypeNode<Type>, AlwaysDependent;
+def OCamlRawType : TypeNode<Type>;
diff --git a/clang/lib/AST/ASTContext.cpp b/clang/lib/AST/ASTContext.cpp
@@ -2326,6 +2326,12 @@ TypeInfo ASTContext::getTypeInfoImpl(const Type *T) const {
     Width = llvm::alignTo(EIT->getNumBits(), Align);
     break;
   }
+  case Type::OCamlRaw: {
+    const auto *ORT = cast<OCamlRawType>(T);
+    Align = std::min(8U, static_cast<unsigned>(llvm::PowerOf2Ceil(ORT->getNumBits())));
+    Width = ORT->getNumBits();
+    break;
+  }
   case Type::Record:
   case Type::Enum: {
     const auto *TT = cast<TagType>(T);
@@ -4587,6 +4593,20 @@ QualType ASTContext::getBitIntType(bool IsUnsigned, unsigned NumBits) const {
   return QualType(New, 0);
 }
 
+QualType ASTContext::getOCamlRawType(unsigned NumBits) const {
+  llvm::FoldingSetNodeID ID;
+  OCamlRawType::Profile(ID, NumBits);
+
+  void *InsertPos = nullptr;
+  if (OCamlRawType *ORT = OCamlRawTypes.FindNodeOrInsertPos(ID, InsertPos))
+    return QualType(ORT, 0);
+
+  auto *New = new (*this, TypeAlignment) OCamlRawType(NumBits);
+  OCamlRawTypes.InsertNode(New, InsertPos);
+  Types.push_back(New);
+  return QualType(New, 0);
+}
+
 QualType ASTContext::getDependentBitIntType(bool IsUnsigned,
                                             Expr *NumBitsExpr) const {
   assert(NumBitsExpr->isInstantiationDependent() && "Only good for dependent");
diff --git a/clang/lib/AST/ItaniumMangle.cpp b/clang/lib/AST/ItaniumMangle.cpp
@@ -4053,6 +4053,11 @@ void CXXNameMangler::mangleType(const DependentBitIntType *T) {
   Out << "_";
 }
 
+void CXXNameMangler::mangleType(const OCamlRawType *T) {
+  // This should never be called in practice for lldb usage
+  llvm_unreachable("OCamlRaw types should not be mangled");
+}
+
 void CXXNameMangler::mangleIntegerLiteral(QualType T,
                                           const llvm::APSInt &Value) {
   //  <expr-primary> ::= L <type> <value number> E # integer literal
diff --git a/clang/lib/AST/MicrosoftMangle.cpp b/clang/lib/AST/MicrosoftMangle.cpp
@@ -3409,6 +3409,12 @@ void MicrosoftCXXNameMangler::mangleType(const DependentBitIntType *T,
   Diags.Report(Range.getBegin(), DiagID) << Range;
 }
 
+void MicrosoftCXXNameMangler::mangleType(const OCamlRawType *T,
+                                         Qualifiers, SourceRange Range) {
+  // This should never be called in practice for lldb usage
+  llvm_unreachable("OCamlRaw types should not be mangled");
+}
+
 // <this-adjustment> ::= <no-adjustment> | <static-adjustment> |
 //                       <virtual-adjustment>
 // <no-adjustment>      ::= A # private near
diff --git a/clang/lib/AST/Type.cpp b/clang/lib/AST/Type.cpp
@@ -342,6 +342,9 @@ BitIntType::BitIntType(bool IsUnsigned, unsigned NumBits)
     : Type(BitInt, QualType{}, TypeDependence::None), IsUnsigned(IsUnsigned),
       NumBits(NumBits) {}
 
+OCamlRawType::OCamlRawType(unsigned NumBits)
+    : Type(OCamlRaw, QualType{}, TypeDependence::None), NumBits(NumBits) {}
+
 DependentBitIntType::DependentBitIntType(const ASTContext &Context,
                                          bool IsUnsigned, Expr *NumBitsExpr)
     : Type(DependentBitInt, QualType{},
diff --git a/clang/lib/AST/TypePrinter.cpp b/clang/lib/AST/TypePrinter.cpp
@@ -246,6 +246,7 @@ bool TypePrinter::canPrefixQualifiers(const Type *T,
     case Type::Pipe:
     case Type::BitInt:
     case Type::DependentBitInt:
+    case Type::OCamlRaw:
     case Type::BTFTagAttributed:
       CanPrefixQualifiers = true;
       break;
@@ -1256,6 +1257,13 @@ void TypePrinter::printDependentBitIntBefore(const DependentBitIntType *T,
 void TypePrinter::printDependentBitIntAfter(const DependentBitIntType *T,
                                             raw_ostream &OS) {}
 
+void TypePrinter::printOCamlRawBefore(const OCamlRawType *T, raw_ostream &OS) {
+  OS << "ocaml_raw<" << T->getNumBits() << ">";
+  spaceBeforePlaceHolder(OS);
+}
+
+void TypePrinter::printOCamlRawAfter(const OCamlRawType *T, raw_ostream &OS) {}
+
 /// Appends the given scope to the end of a string.
 void TypePrinter::AppendScope(DeclContext *DC, raw_ostream &OS,
                               DeclarationName NameInScope) {
diff --git a/clang/lib/Sema/SemaTemplate.cpp b/clang/lib/Sema/SemaTemplate.cpp
@@ -6387,6 +6387,10 @@ bool UnnamedLocalNoLinkageFinder::VisitDependentBitIntType(
   return false;
 }
 
+bool UnnamedLocalNoLinkageFinder::VisitOCamlRawType(const OCamlRawType *T) {
+  return false;
+}
+
 bool UnnamedLocalNoLinkageFinder::VisitTagDecl(const TagDecl *Tag) {
   if (Tag->getDeclContext()->isFunctionOrMethod()) {
     S.Diag(SR.getBegin(),
diff --git a/clang/lib/Sema/TreeTransform.h b/clang/lib/Sema/TreeTransform.h
@@ -6662,6 +6662,18 @@ QualType TreeTransform<Derived>::TransformDependentBitIntType(
   return Result;
 }
 
+template <typename Derived>
+QualType TreeTransform<Derived>::TransformOCamlRawType(TypeLocBuilder &TLB,
+                                                       OCamlRawTypeLoc TL) {
+  // OCamlRaw types are never used in template contexts, so just return unchanged
+  const OCamlRawType *T = TL.getTypePtr();
+  QualType Result = QualType(T, 0);
+  
+  OCamlRawTypeLoc NewTL = TLB.push<OCamlRawTypeLoc>(Result);
+  NewTL.setNameLoc(TL.getNameLoc());
+  return Result;
+}
+
   /// Simple iterator that traverses the template arguments in a
   /// container that provides a \c getArgLoc() member function.
   ///
diff --git a/clang/lib/Serialization/ASTReader.cpp b/clang/lib/Serialization/ASTReader.cpp
@@ -6903,6 +6903,10 @@ void TypeLocReader::VisitDependentBitIntTypeLoc(
   TL.setNameLoc(readSourceLocation());
 }
 
+void TypeLocReader::VisitOCamlRawTypeLoc(clang::OCamlRawTypeLoc TL) {
+  TL.setNameLoc(readSourceLocation());
+}
+
 void ASTRecordReader::readTypeLoc(TypeLoc TL, LocSeq *ParentSeq) {
   LocSeq::State Seq(ParentSeq);
   TypeLocReader TLR(*this, Seq);
diff --git a/clang/lib/Serialization/ASTWriter.cpp b/clang/lib/Serialization/ASTWriter.cpp
@@ -606,6 +606,10 @@ void TypeLocWriter::VisitDependentBitIntTypeLoc(
   addSourceLocation(TL.getNameLoc());
 }
 
+void TypeLocWriter::VisitOCamlRawTypeLoc(clang::OCamlRawTypeLoc TL) {
+  addSourceLocation(TL.getNameLoc());
+}
+
 void ASTWriter::WriteTypeAbbrevs() {
   using namespace llvm;
 
diff --git a/clang/tools/libclang/CIndex.cpp b/clang/tools/libclang/CIndex.cpp
@@ -1910,6 +1910,7 @@ DEFAULT_TYPELOC_IMPL(SubstTemplateTypeParmPack, Type)
 DEFAULT_TYPELOC_IMPL(Auto, Type)
 DEFAULT_TYPELOC_IMPL(BitInt, Type)
 DEFAULT_TYPELOC_IMPL(DependentBitInt, Type)
+DEFAULT_TYPELOC_IMPL(OCamlRaw, Type)
 
 bool CursorVisitor::VisitCXXRecordDecl(CXXRecordDecl *D) {
   // Visit the nested-name-specifier, if present.
diff --git a/lldb/include/lldb/lldb-enumerations.h b/lldb/include/lldb/lldb-enumerations.h
@@ -201,6 +201,7 @@ enum Format {
   eFormatVoid,        ///< Do not print this
   eFormatUnicode8,
   eFormatOCamlValue,
+  eFormatOCamlRaw,
   kNumFormats
 };
 
diff --git a/lldb/source/Commands/CommandObjectMemory.cpp b/lldb/source/Commands/CommandObjectMemory.cpp
@@ -1421,6 +1421,7 @@ class CommandObjectMemoryWrite : public CommandObjectParsed {
       case eFormatVectorOfFloat64:
       case eFormatVectorOfUInt128:
       case eFormatOCamlValue:
+      case eFormatOCamlRaw:
       case eFormatOSType:
       case eFormatComplexInteger:
       case eFormatAddressInfo:
diff --git a/lldb/source/Core/DumpDataExtractor.cpp b/lldb/source/Core/DumpDataExtractor.cpp
@@ -424,6 +424,19 @@ void PrintAPIntAsFloat(Stream *s, llvm::APInt apint,
 }
 
 
+static offset_t FormatOCamlRaw(const DataExtractor &DE, Stream *s,
+                               offset_t start_offset, size_t item_byte_size) {
+  offset_t offset = start_offset;
+
+  for (size_t i = 0; i < item_byte_size; ++i) {
+    if (i > 0)
+      s->PutChar(' ');
+    s->Printf("%02x", DE.GetU8(&offset));
+  }
+
+  return offset;
+}
+
 static offset_t FormatOCamlValue(const DataExtractor &DE, Stream *s,
                                  offset_t start_offset, uint64_t base_addr,
                                  ExecutionContextScope *exe_ctx_scope,
@@ -1296,6 +1309,11 @@ lldb::offset_t lldb_private::DumpDataExtractor(
                                 pointers_seen, 0);
       break;
     }
+
+    case eFormatOCamlRaw: {
+      offset = FormatOCamlRaw(DE, s, offset, item_byte_size);
+      break;
+    }
     }
   }
 
diff --git a/lldb/source/DataFormatters/FormatManager.cpp b/lldb/source/DataFormatters/FormatManager.cpp
@@ -72,6 +72,7 @@ static constexpr FormatInfo g_format_infos[] = {
     {eFormatVoid, 'v', "void"},
     {eFormatUnicode8, 'u', "unicode8"},
     {eFormatOCamlValue, '\0', "ocaml_value"},
+    {eFormatOCamlRaw, '\0', "ocaml_raw"},
 };
 
 static_assert((sizeof(g_format_infos) / sizeof(g_format_infos[0])) ==
diff --git a/lldb/source/Plugins/TypeSystem/Clang/TypeSystemClang.cpp b/lldb/source/Plugins/TypeSystem/Clang/TypeSystemClang.cpp
@@ -1060,6 +1060,11 @@ CompilerType TypeSystemClang::GetBuiltinTypeForDWARFEncodingAndBitSize(
       }
       if (type_name == "ocaml_value")
         return GetType(ast.OCamlValueTy);
+
+      if (type_name == "ocaml_raw") {
+        // Create OCamlRawType with the correct bit size
+        return GetType(ast.getOCamlRawType(bit_size));
+      }
     }
     // We weren't able to match up a type name, just search by size
     if (QualTypeMatchesBitSize(bit_size, ast, ast.CharTy))
@@ -4069,6 +4074,8 @@ TypeSystemClang::GetTypeInfo(lldb::opaque_compiler_type_t type,
     }
     return vector_type_flags;
   }
+  case clang::Type::OCamlRaw:
+    return eTypeHasValue | eTypeIsBuiltIn;
   default:
     return 0;
   }
@@ -9395,6 +9402,16 @@ bool TypeSystemClang::DumpTypeValue(
                                0, 0, exe_scope);
     }
 
+    if (qual_type->getTypeClass() == clang::Type::OCamlRaw) {
+      const clang::OCamlRawType *ocaml_raw_type =
+        llvm::cast<clang::OCamlRawType>(qual_type.getTypePtr());
+      size_t ocaml_raw_byte_size = ocaml_raw_type->getNumBits() / 8;
+      return DumpDataExtractor(data, s, byte_offset, eFormatOCamlRaw,
+                               ocaml_raw_byte_size, 1,
+                               UINT32_MAX, LLDB_INVALID_ADDRESS,
+                               0, 0, exe_scope);
+    }
+
     if (is_ocaml_array) {
       return DumpTypeOcamlArray(qual_type, s, data, byte_offset, byte_size,
           exe_scope, array_element_type);
