From 7cf6f308356d45fe1bdde18d42f113f6238849b1 Mon Sep 17 00:00:00 2001
From: Samuel Hammersberg <samuel.hammersberg@gmail.com>
Date: Fri, 24 Feb 2023 18:37:31 +0100
Subject: [PATCH] Data type constructors now properly tag the data.

---
 src/Compiler.hs | 46 +++++++++++++++++++++++++++++++++-------------
 src/LlvmIr.hs   |  7 +++++++
 2 files changed, 40 insertions(+), 13 deletions(-)

diff --git a/src/Compiler.hs b/src/Compiler.hs
index bbcde26..3b57dbe 100644
--- a/src/Compiler.hs
+++ b/src/Compiler.hs
@@ -5,6 +5,7 @@ module Compiler (compile) where
 
 import           Auxiliary            (snoc)
 import           Control.Monad.State  (StateT, execStateT, gets, modify)
+import qualified Data.Bifunctor       as BI
 import           Data.List.Extra      (trim)
 import           Data.Map             (Map)
 import qualified Data.Map             as Map
@@ -16,7 +17,6 @@ import           LlvmIr               (CallingConvention (..), LLVMComp (..),
                                        LLVMValue (..), Visibility (..),
                                        llvmIrToString)
 import           System.Process.Extra (readCreateProcess, shell)
-import           TypeChecker          (partitionType)
 import           TypeCheckerIr        (Bind (..), Case (..), Exp (..), Id,
                                        Ident (..), Program (..), Type (..))
 
@@ -24,7 +24,7 @@ import           TypeCheckerIr        (Bind (..), Case (..), Exp (..), Id,
 data CodeGenerator = CodeGenerator
     { instructions  :: [LLVMIr]
     , functions     :: Map Id FunctionInfo
-    , constructors  :: Map Id FunctionInfo
+    , constructors  :: Map Id ConstructorInfo
     , variableCount :: Integer
     , labelCount    :: Integer
     }
@@ -36,7 +36,12 @@ data FunctionInfo = FunctionInfo
     { numArgs   :: Int
     , arguments :: [Id]
     }
-    deriving Show
+data ConstructorInfo = ConstructorInfo
+    { numArgsCI   :: Int
+    , argumentsCI :: [Id]
+    , numCI       :: Integer
+    }
+
 
 -- | Adds a instruction to the CodeGenerator state
 emit :: LLVMIr -> CompilerState ()
@@ -80,14 +85,16 @@ createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(Ident ("arg_" <> show l) ,
 
 -- | Produces a map of functions infos from a list of binds,
 --  which contains useful data for code generation.
-getConstructors :: [Bind] -> Map Id FunctionInfo
+getConstructors :: [Bind] -> Map Id ConstructorInfo
 getConstructors bs = Map.fromList $ go bs
   where
     go [] = []
     go (DataStructure n cons : xs) = do
-        map (\(id, xs) -> ((id, TPol n), FunctionInfo {
-            numArgs=length xs, arguments=createArgs xs
-        })) cons
+        fst (foldl (\(acc,i) (id, xs) -> (((id, TPol n), ConstructorInfo {
+            numArgsCI=length xs,
+            argumentsCI=createArgs xs,
+            numCI=i
+        }) : acc, i+1)) ([],0) cons)
         <> go xs
     go (_: xs) = go xs
 
@@ -130,12 +137,25 @@ compile (Program scs) = do
 
 compileScs :: [Bind] -> CompilerState ()
 compileScs []                             = do
-    return ()
-    -- c <- gets (Map.toList . constructors)
-    -- mapM_ (\((id, t), fi) -> do
-    --         emit $ Define FastCC (type2LlvmType t) id []
-    --         emit DefineEnd
-    --     ) c
+    -- as a last step create all the constructors
+    c <- gets (Map.toList . constructors)
+    mapM_ (\((id, t), ci) -> do
+            let x = BI.second type2LlvmType <$> argumentsCI ci
+            emit $ Define FastCC (type2LlvmType t) id x
+            top <- Ident . show <$> getNewVar
+            ptr <- Ident . show <$> getNewVar
+            emit $ SetVariable top (Alloca (type2LlvmType t))
+            -- %0 = getelementptr inbounds %Foo, %Foo* %x, i32 0, i32 0
+            emit $ SetVariable ptr $
+                GetElementPtrInbounds (type2LlvmType t) (Ref $ type2LlvmType t)
+                                      (VIdent top I8) I32 (VInteger 0) I32 (VInteger 0)
+            emit $ Store I8 (VInteger $ numCI ci ) (Ref I8) ptr
+            -- store i8 1, i8* %0
+            emit $ Ret I64 (VInteger 0)
+            emit DefineEnd
+
+            modify $ \s -> s { variableCount = 0 }
+        ) c
 compileScs (Bind (name, _t) args exp : xs) = do
     emit $ UnsafeRaw "\n"
     emit . Comment $ show name <> ": " <> show exp
diff --git a/src/LlvmIr.hs b/src/LlvmIr.hs
index 2a96957..8f07346 100644
--- a/src/LlvmIr.hs
+++ b/src/LlvmIr.hs
@@ -104,6 +104,7 @@ data LLVMIr
     | Declare LLVMType Ident Params
     | SetVariable Ident LLVMIr
     | Variable Ident
+    | GetElementPtrInbounds LLVMType LLVMType LLVMValue LLVMType LLVMValue LLVMType LLVMValue
     | Add LLVMType LLVMValue LLVMValue
     | Sub LLVMType LLVMValue LLVMValue
     | Div LLVMType LLVMValue LLVMValue
@@ -144,6 +145,12 @@ llvmIrToString = go 0
     insToString :: Int -> LLVMIr -> String
     insToString i l =
         replicate i '\t' <> case l of
+            (GetElementPtrInbounds t1 t2 p t3 v1 t4 v2) -> do
+                -- getelementptr inbounds %Foo, %Foo* %x, i32 0, i32 0
+                concat
+                    [ "getelementptr inbounds ", show t1, ", " , show t2
+                    , " ", show p, ", ", show t3, " ", show v1,
+                    ", ", show t4, " ", show v2, "\n" ]
             (Type (Ident n) types) ->
                 concat
                     [ "%", n, " = type { "