From 129a70e051c4a0ef6a810dd26464fcf805fa434d Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Thu, 23 Mar 2023 15:29:25 +0100 Subject: [PATCH] WIP Added support for more types of cases. --- src/Codegen/Codegen.hs | 83 +++++++++++++++++++++------- src/Codegen/LlvmIr.hs | 20 +++++-- src/Monomorphizer/MonomorphizerIr.hs | 2 +- 3 files changed, 79 insertions(+), 26 deletions(-) diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index bf2f9ba..e0c52aa 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -129,13 +129,15 @@ test v = Program , Bind (GA.Ident "main", MIR.Type (GA.Ident "_Int")) [] --(EApp (MIR.Type (GA.Ident "Craig")) (EId (GA.Ident "Craig_Bob", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) (ELit (LInt v), MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "Craig"))-- (EInt 92) $ eCaseInt (EApp (MIR.Type (GA.Ident "Craig")) (EId (GA.Ident "Craig_Bob", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) (ELit (LInt v), MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "Craig")) - [ injectionCons "Craig_Betty" "Craig" (int 5) + [ injectionCons "Craig_Bob" "Craig" [CIdent (GA.Ident "x")] (EId (GA.Ident "x", MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "_Int")) + , injectionCons "Craig_Betty" "Craig" [CLit (LInt 5)] (int 2) + , Injection (CIdent (GA.Ident "z")) (int 3) --, injectionInt 5 (int 6) , injectionCatchAll (int 10) ] ] where - injectionCons x y = Injection (CCons (GA.Ident x, MIR.Type (GA.Ident y))) + injectionCons x y xs = Injection (CCons (GA.Ident x, MIR.Type (GA.Ident y)) xs) injectionInt x = Injection (CLit (LInt x)) injectionCatchAll = Injection CatchAll eCaseInt x xs = (ECase (MIR.Type "_Int") x xs, MIR.Type "_Int") @@ -173,11 +175,11 @@ compileScs [] = do -- get a pointer of the correct type ptr' <- getNewVar - emit $ SetVariable ptr' (Bitcast (Ref t') top (Ref $ CustomType id)) + emit $ SetVariable ptr' (Bitcast (Ref t') (VIdent top Ptr) (Ref $ CustomType id)) --emit $ UnsafeRaw "\n" - foldM_ (\i (GA.Ident arg_n, arg_t)-> do + enumerateOneM_ (\i (GA.Ident arg_n, arg_t) -> do let arg_t' = type2LlvmType arg_t emit $ Comment (show arg_t' <>" "<> arg_n <> " " <> show i ) elemPtr <- getNewVar @@ -187,10 +189,7 @@ compileScs [] = do I64 (VInteger 0) I32 (VInteger i)) emit $ Store arg_t' (VIdent (GA.Ident arg_n) arg_t') Ptr elemPtr - -- %2 = getelementptr inbounds %Foo_AInteger, %Foo_AInteger* %1, i32 0, i32 1 - -- store i32 42, i32* %2 - pure $ i + 1-- + typeByteSize arg_t' - ) 1 (argumentsCI ci) + ) (argumentsCI ci) --emit $ UnsafeRaw "\n" @@ -264,43 +263,74 @@ compileExp (EId (name, _)) = emitIdent name compileExp (EApp t e1 e2) = emitApp t (fst e1) (fst e2) --compileExp (EAbs t ti e) = emitAbs t ti e compileExp (ELet _ binds e) = undefined emitLet binds (fst e) -compileExp (ECase t e cs) = emitECased t (fst e) (map (t,) cs) +compileExp (ECase t e cs) = emitECased t e (map (t,) cs) -- go (EMul e1 e2) = emitMul e1 e2 -- go (EDiv e1 e2) = emitDiv e1 e2 -- go (EMod e1 e2) = emitMod e1 e2 --- aux functions --- -emitECased :: Type -> Exp -> [(Type, Injection)] -> CompilerState () +emitECased :: Type -> ExpT -> [(Type, Injection)] -> CompilerState () emitECased t e cases = do let cs = snd <$> cases let ty = type2LlvmType t - vs <- exprToValue e + let rt = type2LlvmType (snd e) + vs <- exprToValue (fst e) lbl <- getNewLabel let label = GA.Ident $ "escape_" <> show lbl stackPtr <- getNewVar emit $ SetVariable stackPtr (Alloca ty) - mapM_ (emitCases ty label stackPtr vs) cs + mapM_ (emitCases rt ty label stackPtr vs) cs emit $ Label label res <- getNewVar emit $ SetVariable res (Load ty Ptr stackPtr) where - emitCases :: LLVMType -> GA.Ident -> GA.Ident -> LLVMValue -> Injection -> CompilerState () - emitCases ty label stackPtr vs (Injection (MIR.CCons id) exp) = do + emitCases :: LLVMType -> LLVMType -> GA.Ident -> GA.Ident -> LLVMValue -> Injection -> CompilerState () + emitCases rt ty label stackPtr vs (Injection (MIR.CCons consId cs) exp) = do cons <- gets constructors - let r = fromJust $ Map.lookup id cons + let r = fromJust $ Map.lookup consId cons lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel + consVal <- getNewVar + emit $ SetVariable consVal (ExtractValue rt vs 0) + consCheck <- getNewVar - emit $ SetVariable consCheck (Icmp LLEq I8 vs (VInteger $ numCI r)) + emit $ SetVariable consCheck (Icmp LLEq I8 (VIdent consVal I8) (VInteger $ numCI r)) emit $ BrCond (VIdent consCheck ty) lbl_succPos lbl_failPos emit $ Label lbl_succPos + + castPtr <- getNewVar + castedPtr <- getNewVar + casted <- getNewVar + emit $ SetVariable castPtr (Alloca rt) + emit $ Store rt vs Ptr castPtr + emit $ SetVariable castedPtr (Bitcast Ptr (VIdent castPtr Ptr) Ptr) + emit $ SetVariable casted (Load (CustomType (fst consId)) Ptr castedPtr) + val <- exprToValue (fst exp) - emit $ Store ty val Ptr stackPtr + enumerateOneM_ (\i c -> do + case c of + CIdent x -> do + emit . Comment $ "ident " <> show x + emit $ SetVariable x (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i) + emit $ Store ty val Ptr stackPtr + CCons x cs -> error "nested constructor" + CLit l -> do + testVar <- getNewVar + emit $ SetVariable testVar (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i) + case l of + LInt l -> emit $ Icmp LLEq I64 (VIdent testVar Ptr) (VInteger l) + LChar c -> emit $ Icmp LLEq I8 (VIdent testVar Ptr) (VChar c) + CatchAll -> emit . Comment $ "Catch all" + emit . Comment $ "return this " <> show val + emit . Comment . show $ c + emit . Comment . show $ i + ) cs + -- emit $ Store ty val Ptr stackPtr emit $ Br label emit $ Label lbl_failPos - emitCases ty label stackPtr vs (Injection (MIR.CLit i) exp) = do + emitCases rt ty label stackPtr vs (Injection (MIR.CLit i) exp) = do let i' = case i of LInt i -> VInteger i LChar i -> VChar i @@ -314,7 +344,17 @@ emitECased t e cases = do emit $ Store ty val Ptr stackPtr emit $ Br label emit $ Label lbl_failPos - emitCases ty label stackPtr _ (Injection MIR.CatchAll exp) = do + emitCases rt ty label stackPtr vs (Injection (MIR.CIdent id) exp) = do + -- //TODO this is pretty disgusting and would heavily benefit from a rewrite + valPtr <- getNewVar + emit $ SetVariable valPtr (Alloca rt) + emit $ Store rt vs Ptr valPtr + emit $ SetVariable id (Load rt Ptr valPtr) + increaseVarCount + val <- exprToValue (fst exp) + emit $ Store ty val Ptr stackPtr + emit $ Br label + emitCases _ ty label stackPtr _ (Injection MIR.CatchAll exp) = do val <- exprToValue (fst exp) emit $ Store ty val Ptr stackPtr emit $ Br label @@ -435,6 +475,7 @@ getType (ECase t _ _) = type2LlvmType t valueGetType :: LLVMValue -> LLVMType valueGetType (VInteger _) = I64 +valueGetType (VChar _) = I8 valueGetType (VIdent _ t) = t valueGetType (VConstant s) = Array (fromIntegral $ length s) I8 valueGetType (VFunction _ _ t) = t @@ -449,3 +490,7 @@ typeByteSize (Ref _) = 8 typeByteSize (Function _ _) = 8 typeByteSize (Array n t) = n * typeByteSize t typeByteSize (CustomType _) = 8 + +enumerateOneM_ :: Monad m => (Integer -> a -> m b) -> [a] -> m () +enumerateOneM_ f = foldM_ (\i a -> f i a >> pure (i + 1)) 1 + diff --git a/src/Codegen/LlvmIr.hs b/src/Codegen/LlvmIr.hs index 7a0cf82..ea73b90 100644 --- a/src/Codegen/LlvmIr.hs +++ b/src/Codegen/LlvmIr.hs @@ -106,6 +106,8 @@ data LLVMIr | Declare LLVMType Ident Params | SetVariable Ident LLVMIr | Variable Ident + -- extractvalue , {, }* + | ExtractValue LLVMType LLVMValue Integer | GetElementPtr LLVMType LLVMType LLVMValue LLVMType LLVMValue LLVMType LLVMValue | GetElementPtrInbounds LLVMType LLVMType LLVMValue LLVMType LLVMValue LLVMType LLVMValue | Add LLVMType LLVMValue LLVMValue @@ -121,7 +123,7 @@ data LLVMIr | Alloca LLVMType | Store LLVMType LLVMValue LLVMType Ident | Load LLVMType LLVMType Ident - | Bitcast LLVMType Ident LLVMType + | Bitcast LLVMType LLVMValue LLVMType | Ret LLVMType LLVMValue | Comment String | UnsafeRaw String -- This should generally be avoided, and proper @@ -151,8 +153,14 @@ llvmIrToString = go 0 -- getelementptr inbounds %Foo, %Foo* %x, i32 0, i32 0 concat [ "getelementptr ", show t1, ", " , show t2 - , " ", show p, ", ", show t3, " ", show v1, - ", ", show t4, " ", show v2, "\n" ] + , " ", show p, ", ", show t3, " ", show v1 + , ", ", show t4, " ", show v2, "\n" + ] + (ExtractValue t1 v i) -> do + concat + [ "extractvalue ", show t1, " " + , show v, ", ", show i, "\n" + ] (GetElementPtrInbounds t1 t2 p t3 v1 t4 v2) -> do -- getelementptr inbounds %Foo, %Foo* %x, i32 0, i32 0 concat @@ -216,10 +224,10 @@ llvmIrToString = go 0 [ "load ", show t1, ", " , show t2, " %", addr, "\n" ] - (Bitcast t1 (Ident i) t2) -> + (Bitcast t1 v t2) -> concat - [ "bitcast ", show t1, " %" - , i, " to ", show t2, "\n" + [ "bitcast ", show t1, " " + , show v, " to ", show t2, "\n" ] (Icmp comp t v1 v2) -> concat diff --git a/src/Monomorphizer/MonomorphizerIr.hs b/src/Monomorphizer/MonomorphizerIr.hs index 38b230e..606a719 100644 --- a/src/Monomorphizer/MonomorphizerIr.hs +++ b/src/Monomorphizer/MonomorphizerIr.hs @@ -19,7 +19,7 @@ data Exp data Injection = Injection Case ExpT deriving (Show, Ord, Eq) -data Case = CLit Lit | CCons Id | CatchAll +data Case = CLit Lit | CCons Id [Case] | CIdent Ident | CatchAll deriving (Show, Ord, Eq) data Constructor = Constructor Ident [Type]