wip

wip

wip

builtin/Builtin.vix

@@ -18,7 +18,11 @@ subInt : Int -> Int -> Int
 
 EmptyRepresentation : Type
 WordRepresentation : Type
+PointerRepresentation : Type
 
 maxRepresentation : Type -> Type -> Type
 addRepresentation : Type -> Type -> Type
 
+representationBytes : Type -> Int
+representationPointers : Type -> Int
+representationNonPointerBytes : Type -> Int

rts/Sixten.Builtin.ll

@@ -2,10 +2,11 @@
 declare void @print_int(i64 %i)
 declare void @exit(i32)
 
-@Sixten.Builtin.Int = unnamed_addr constant i64 8
-@Sixten.Builtin.Type = unnamed_addr constant i64 8
+@Sixten.Builtin.Int = unnamed_addr constant i64 u0x0000000800000000
+@Sixten.Builtin.Type = unnamed_addr constant i64 u0x0000000800000000
 @Sixten.Builtin.EmptyRepresentation = unnamed_addr constant i64 0
-@Sixten.Builtin.WordRepresentation = unnamed_addr constant i64 8
+@Sixten.Builtin.PointerRepresentation = unnamed_addr constant i64 u0x0000000000000008
+@Sixten.Builtin.WordRepresentation = unnamed_addr constant i64 u0x0000000800000000
 
 define external fastcc void @Sixten.Builtin.unknown(ptr %destination, i64 %a) {
   call void @exit(i32 7411)
@@ -18,15 +19,25 @@ define external fastcc i64 @Sixten.Builtin.addRepresentation(i64 %a, i64 %b) {
 }
 
 define external fastcc i64 @Sixten.Builtin.maxRepresentation(i64 %a, i64 %b) {
-  %a_lt_b = icmp ult i64 %a, %b
-  %result = select i1 %a_lt_b, i64 %b, i64 %a
+  %a_ptrs = trunc i64 %a to i32
+  %b_ptrs = trunc i64 %b to i32
+  %a_non_ptrs64 = lshr i64 %a, 32
+  %b_non_ptrs64 = lshr i64 %b, 32
+  %a_non_ptrs = trunc i64 %a_non_ptrs64 to i32
+  %b_non_ptrs = trunc i64 %b_non_ptrs64 to i32
+  %a_ptrs_lt_b_ptrs = icmp ult i32 %a_ptrs, %b_ptrs
+  %result_ptrs = select i1 %a_ptrs_lt_b_ptrs, i32 %b_ptrs, i32 %a_ptrs
+  %a_non_ptrs_lt_b_non_ptrs = icmp ult i32 %a_non_ptrs, %b_non_ptrs
+  %result_non_ptrs = select i1 %a_non_ptrs_lt_b_non_ptrs, i32 %b_non_ptrs, i32 %a_non_ptrs
+  %result_lower = zext i32 %result_ptrs to i64
+  %result_non_ptrs64 = zext i32 %result_non_ptrs to i64
+  %result_upper = shl nuw i64 %result_non_ptrs64, 32
+  %result = or i64 %result_lower, %result_upper
   ret i64 %result
 }
 
-define external fastcc void @Sixten.Builtin.printInt(i64 %tagged_i) {
-  %i = ashr i64 %tagged_i, 1
+define external fastcc void @Sixten.Builtin.printInt(i64 %i) {
   call void @print_int(i64 %i)
-  ret void
 }
 
 define external fastcc i64 @Sixten.Builtin.addInt(i64 %a, i64 %b) {
@@ -35,12 +46,29 @@ define external fastcc i64 @Sixten.Builtin.addInt(i64 %a, i64 %b) {
 }
 
 define external fastcc i64 @Sixten.Builtin.mulInt(i64 %a, i64 %b) {
-  %doubled_result = mul i64 %a, %b
-  %result = ashr i64 %doubled_result, 1
+  %result = mul i64 %a, %b
   ret i64 %result
 }
 
 define external fastcc i64 @Sixten.Builtin.subInt(i64 %a, i64 %b) {
   %result = sub i64 %a, %b
   ret i64 %result
 }
+
+define external fastcc i64 @Sixten.Builtin.representationBytes(i64 %a) {
+  %ptr_bytes = call fastcc i64 @Sixten.Builtin.representationPointerBytes(i64 %a)
+  %non_ptr_bytes = call fastcc i64 @Sixten.Builtin.representationNonPointerBytes(i64 %a)
+  %bytes = add nuw i64 %ptr_bytes, %non_ptr_bytes
+  ret i64 %bytes
+}
+
+define external fastcc i64 @Sixten.Builtin.representationPointerBytes(i64 %a) {
+  %ptrs = trunc i64 %a to i32
+  %ptrs64 = zext i32 %ptrs to i64
+  ret i64 %ptrs64
+}
+
+define external fastcc i64 @Sixten.Builtin.representationNonPointerBytes(i64 %a) {
+  %non_ptrs = lshr i64 %b, 32
+  ret i64 %non_ptrs
+}

rts/reference_counting.c

@@ -5,6 +5,7 @@
 #define unlikely(x) __builtin_expect(!!(x), 0)
 #define debug_printf(...) // printf(__VA_ARGS__)
 
+<<<<<<< HEAD
 const uintptr_t INLINE_SIZE_MASK = 0xFF << 3;
 
 // heap pointer: | 45 bits pointer data | 8 bits constructor tag | 8 bits word size | 2 bits object type | 1 |
@@ -82,6 +83,63 @@ uintptr_t sixten_allocate(uintptr_t constructor_tag, uintptr_t size){
     | ((uintptr_t)constructor_tag << 11)
     | (uintptr_t)inline_size
     | 1;
+=======
+// pointer: 48 bits pointer data
+//        | 16 bits constructor tag
+// pointee: 32 bits ref count |
+//        | 32 bits pointer bytes
+// ptr -> | pointer data
+//        | non-pointer data
+
+typedef uint32_t ReferenceCount;
+typedef uint32_t PointerBytes;
+const size_t POINTER_OFFSET = 16;
+const uintptr_t CONSTRUCTOR_TAG_MASK = UINTPTR_C(0xffff);
+
+static
+void print_heap_object(uintptr_t heap_object) {
+  char* data = sixten_heap_object_data(heap_object);
+  debug_printf("data: 0x%" PRIxPTR, (uintptr_t)data);
+  uintptr_t constructor_tag = sixten_heap_object_constructor_tag(heap_object);
+  debug_printf(", constructor_tag: %" PRIuPTR, constructor_tag);
+  uintptr_t inline_pointers = sixten_heap_object_pointer_bytes(heap_object);
+  debug_printf(", pointer_bytes: %" PRIuPTR, pointer_bytes);
+}
+
+char* sixten_heap_object_data(uintptr_t word) {
+  return (char*)((intptr_t)word >> POINTER_OFFSET);
+}
+
+uintptr_t sixten_heap_object_constructor_tag(uintptr_t word) {
+  return word & CONSTRUCTOR_TAG_MASK;
+}
+
+uintptr_t sixten_heap_object_pointer_bytes(uintptr_t word) {
+  char* data = sixten_heap_object_data(word);
+  if (data == 0) {
+    return 0;
+  }
+  return *(PointerBytes*)(data - sizeof(PointerBytes));
+}
+
+uintptr_t sixten_allocate(uintptr_t constructor_tag, uintptr_t pointer_bytes, uintptr_t non_pointer_bytes){
+  debug_printf("heap allocating %" PRIuPTR " bytes \n", bytes);
+  uintptr_t bytes = pointer_bytes + non_pointer_bytes;
+  if (bytes == 0) {
+    return constructor_tag & CONSTRUCTOR_TAG_MASK;
+  }
+  bytes += sizeof(ReferenceCount);
+  bytes += sizeof(PointerBytes);
+
+  char* heap_pointer = mi_malloc(bytes);
+  char* object_pointer = heap_pointer + sizeof(ReferenceCount) + sizeof(PointerBytes);
+  *(ReferenceCount*)heap_pointer = 1;
+  *(PointerBytes*)(heap_pointer + sizeof(ReferenceCount)) = pointer_bytes;
+
+  uintptr_t result
+    = ((uintptr_t)object_pointer << POINTER_OFFSET)
+    | (constructor_tag & CONSTRUCTOR_TAG_MASK);
+>>>>>>> 6db7d94 (wip)
 
   debug_printf("heap allocated object ");
   print_heap_object(result);

rts/reference_counting.h

@@ -2,6 +2,7 @@
 
 #include <stdint.h>
 
+<<<<<<< HEAD
 int sixten_is_heap_object(uintptr_t word);
 uintptr_t sixten_heap_object_size(uintptr_t word);
 char* sixten_heap_object_pointer(uintptr_t word);
@@ -13,3 +14,14 @@ void sixten_retain(uintptr_t word);
 void sixten_retains(char* pointer, uintptr_t size);
 void sixten_release(uintptr_t word);
 void sixten_releases(char* pointer, uintptr_t size);
+=======
+char* sixten_heap_object_data(uintptr_t word);
+uintptr_t sixten_heap_object_constructor_tag(uintptr_t word);
+uintptr_t sixten_heap_object_pointer_bytes(uintptr_t word);
+
+uintptr_t sixten_allocate(uintptr_t constructor_tag, uintptr_t pointer_bytes, uintptr_t non_pointer_bytes);
+void sixten_retain(uintptr_t word);
+void sixten_retains(char* pointer, uintptr_t pointer_bytes);
+void sixten_release(uintptr_t word);
+void sixten_releases(char* pointer, uintptr_t pointer_bytes);
+>>>>>>> 6db7d94 (wip)

src/Assembly.hs

@@ -26,15 +26,13 @@ data Operand
   = LocalOperand !Local
   | GlobalConstant !Name.Lifted !Type
   | GlobalFunction !Name.Lifted !(Return Type) [Type]
-  | StructOperand [Operand]
   | Lit !Literal
   deriving (Eq, Show, Generic, Hashable)
 
 data Type
   = Word
   | WordPointer
   | FunctionPointer !(Return Type) [Type]
-  | Struct [Type]
   deriving (Eq, Show, Generic, Hashable)
 
 data Return a = Void | Return a
@@ -58,9 +56,14 @@ data Instruction
       , constructorTag :: !Word8
       , size :: !Operand
       }
+  | Retains !Operand !Operand
+  | Releases !Operand !Operand
+  | AllocateGlobal
+      { destination :: !Local
+      , size :: !Operand
+      }
   | ExtractHeapPointer !Local !Operand
   | ExtractHeapPointerConstructorTag !Local !Operand
-  | ExtractValue !Local !Operand !Int
   | Switch !(Return (Type, Local)) !Operand [(Integer, BasicBlock)] BasicBlock
   deriving (Eq, Show, Generic, Hashable)
 
@@ -108,8 +111,6 @@ instance Pretty Operand where
         "(" <> pretty type_ <+> "constant" <+> pretty global <> ")"
       GlobalFunction global return_ arity ->
         "(function " <> pretty return_ <> " (" <> pretty arity <> ")" <+> pretty global <> ")"
-      StructOperand operands ->
-        "{" <> hsep (punctuate comma $ pretty <$> operands) <> "}"
       Lit lit ->
         pretty lit
 
@@ -119,7 +120,6 @@ instance Pretty Type where
       Word -> "word"
       WordPointer -> "word*"
       FunctionPointer returnType argTypes -> pretty returnType <+> tupled (pretty <$> argTypes)
-      Struct types -> "{" <> hsep (punctuate comma $ pretty <$> types) <> "}"
 
 instance Pretty Instruction where
   pretty instruction =
@@ -151,13 +151,17 @@ instance Pretty Instruction where
       RestoreStack o ->
         voidInstr "restorestack" [o]
       HeapAllocate dst a b ->
-        returningInstr dst "heap_alloc" [Lit $ Literal.Integer $ fromIntegral a, b]
+        returningInstr dst "gcmalloc" [Lit $ Literal.Integer $ fromIntegral a, b]
+      Retains pointer size_ ->
+        voidInstr "retains" [pointer, size_]
+      Releases pointer size_ ->
+        voidInstr "releases" [pointer, size_]
+      AllocateGlobal dst size_ ->
+        returningInstr dst "malloc" [size_]
       ExtractHeapPointer dst a ->
         returningInstr dst "extract heap pointer" [a]
       ExtractHeapPointerConstructorTag dst a ->
         returningInstr dst "extract heap pointer" [a]
-      ExtractValue dst struct index ->
-        pretty dst <+> "=" <+> "extractvalue" <+> hsep [pretty struct, pretty index]
       Switch result scrutinee branches default_ ->
         case result of
           Void -> ""

src/AssemblyToLLVM.hs

@@ -20,7 +20,6 @@ import qualified Data.ByteString.Short as ShortByteString
 import Data.HashMap.Lazy (HashMap)
 import qualified Data.HashMap.Lazy as HashMap
 import qualified Data.HashSet as HashSet
-import qualified Data.List as List
 import Data.String (fromString)
 import qualified Literal
 import qualified Name
@@ -85,16 +84,13 @@ llvmType type_ =
     Assembly.Word -> wordSizedInt
     Assembly.WordPointer -> pointer
     Assembly.FunctionPointer _returnType _argumentTypes -> pointer
-    Assembly.Struct types ->
-      braces $ llvmType <$> types
 
 parameterAttributes :: Assembly.Type -> [Builder]
 parameterAttributes type_ =
   case type_ of
     Assembly.Word -> []
     Assembly.WordPointer -> ["nonnull"]
     Assembly.FunctionPointer {} -> ["nonnull"]
-    Assembly.Struct _ -> []
 
 llvmReturnType :: Assembly.Return Assembly.Type -> Builder
 llvmReturnType result =
@@ -425,7 +421,7 @@ assembleInstruction instruction =
       declare "llvm.stackrestore" $ "declare ccc void @llvm.stackrestore" <> parens [pointer]
       emitInstruction $ "call ccc void @llvm.stackrestore" <> parens [typedOperand argument']
     Assembly.HeapAllocate {destination, constructorTag, size} -> do
-      destination' <- activateLocal Assembly.Word destination
+      destination' <- activateLocal Assembly.WordPointer destination
       size' <- assembleOperandAndCastTo Assembly.Word size
       declare
         "__regcall3__heap_alloc"
@@ -442,6 +438,9 @@ assembleInstruction instruction =
             [ "i8 " <> Builder.word8Dec constructorTag
             , typedOperand size'
             ]
+    Assembly.Retains ptr size -> _
+    Assembly.Releases ptr size -> _
+    Assembly.AllocateGlobal dst size -> _
     Assembly.ExtractHeapPointer destination pointer_ -> do
       destination' <- activateLocal Assembly.WordPointer destination
       pointer' <- assembleOperandAndCastTo Assembly.Word pointer_
@@ -457,14 +456,6 @@ assembleInstruction instruction =
           <> wordSizedInt
           <> " @heap_object_constructor_tag"
           <> parens [typedOperand pointer']
-    Assembly.ExtractValue destination struct index -> do
-      (_nameSuggestion, structType, struct') <- assembleOperand struct
-      case structType of
-        Assembly.Struct types -> do
-          let fieldType = types List.!! index
-          destination' <- activateLocal fieldType destination
-          emitInstruction $ localName destination' <> " = extractvalue " <> typedOperand struct' <> ", " <> Builder.intDec index
-        _ -> panic "AssemblyToLLVM.assembleInstruction: ExtractValue of non-struct"
     Assembly.Switch destination scrutinee branches (Assembly.BasicBlock defaultBranchInstructions defaultBranchResult) -> do
       scrutinee' <- assembleOperandAndCastTo Assembly.Word scrutinee
       branchLabels <- forM branches \(i, _) -> do
@@ -534,8 +525,6 @@ assembleOperand = \case
         emitInstruction $
           localName destination <> " = load " <> llvmType_ <> ", ptr " <> globalName globalName_ <> ", align " <> Builder.intDec alignment
         pure (nameSuggestion, Assembly.WordPointer, TypedOperand {type_ = llvmType_, operand = Local destination})
-      Assembly.Struct types ->
-        pure (nameSuggestion, Assembly.Struct types, TypedOperand {type_ = pointer, operand = Global globalName_})
   Assembly.GlobalFunction global returnType parameterTypes -> do
     let defType = Assembly.FunctionPointer returnType parameterTypes
         globalNameText = Assembly.nameText global
@@ -544,18 +533,6 @@ assembleOperand = \case
         globalType = llvmType defType
     declare globalName_ $ "declare fastcc " <> llvmReturnType returnType <> " " <> globalName globalName_ <> parens (llvmType <$> parameterTypes)
     pure (nameSuggestion, defType, TypedOperand {type_ = globalType, operand = Global globalName_})
-  Assembly.StructOperand operands -> do
-    typedOperands <- mapM assembleOperand operands
-    let types = (\(_, type', _) -> type') <$> typedOperands
-        operands' = (\(_, _, operand') -> operand') <$> typedOperands
-        type_ = Assembly.Struct types
-        llvmType_ = llvmType type_
-        go (index, struct) fieldOperand = do
-          struct' <- freshName "struct"
-          emitInstruction $ localName struct' <> " = insertvalue " <> typedOperand struct <> ", " <> typedOperand fieldOperand <> ", " <> Builder.intDec index
-          pure (index + 1, TypedOperand {type_ = llvmType_, operand = Local struct'})
-    result <- snd <$> foldM go (0, TypedOperand {type_ = llvmType_, operand = Constant "undef"}) operands'
-    pure ("struct", type_, result)
   Assembly.Lit lit ->
     case lit of
       Literal.Integer int ->
@@ -586,20 +563,6 @@ cast nameSuggestion newType type_ operand_
           emitInstruction $
             localName newOperand <> " = ptrtoint " <> typedOperand operand_ <> " to " <> llvmNewType
           pure TypedOperand {type_ = llvmNewType, operand = Local newOperand}
-        (Assembly.Struct types, Assembly.Struct newTypes) -> do
-          let llvmType_ = llvmType type_
-              go (index, struct) (fieldType, newFieldType) = do
-                field <- freshName "field"
-                let fieldOperand = TypedOperand {type_ = llvmType fieldType, operand = Local field}
-                emitInstruction $
-                  localName field <> " = extractvalue " <> typedOperand operand_ <> ", " <> Builder.intDec index
-                castField <- cast "field" newFieldType fieldType fieldOperand
-                struct' <- freshName "struct"
-                emitInstruction $
-                  localName struct' <> " = insertvalue " <> typedOperand struct <> ", " <> typedOperand castField <> ", " <> Builder.intDec index
-                pure (index + 1, TypedOperand {type_ = llvmType_, operand = Local struct'})
-
-          snd <$> foldM go (0, TypedOperand {type_ = llvmType_, operand = Constant "undef"}) (zip types newTypes)
         _ -> do
           newOperand <- freshName $ nameSuggestion <> "_cast"
           emitInstruction $

src/Builtin.hs

@@ -100,6 +100,10 @@ pattern WordRepresentationName :: Name.Qualified
 pattern WordRepresentationName =
   "Sixten.Builtin.WordRepresentation"
 
+pattern PointerRepresentationName :: Name.Qualified
+pattern PointerRepresentationName =
+  "Sixten.Builtin.PointerRepresentation"
+
 pattern AddRepresentationName :: Name.Qualified
 pattern AddRepresentationName =
   "Sixten.Builtin.addRepresentation"