WIP Added support for more types of cases.
This commit is contained in:
Samuel Hammersberg
parent
cd85297b85
commit
129a70e051
3 changed files with 79 additions and 26 deletions
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -106,6 +106,8 @@ data LLVMIr
|
|||
| Declare LLVMType Ident Params
|
||||
| SetVariable Ident LLVMIr
|
||||
| Variable Ident
|
||||
-- extractvalue <aggregate type> <val>, <idx>{, <idx>}*
|
||||
| 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
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue