-- Copyright (C) 2018-2024 Jun Zhang <zhangjunphy[at]gmail[dot]com>
--
-- This file is a part of decafc.
--
-- decafc is free software: you can redistribute it and/or modify it under the
-- terms of the MIT (X11) License as described in the LICENSE file.
--
-- decafc is distributed in the hope that it will be useful, but WITHOUT ANY
-- WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE.  See the X11 license for more details.

-- This should be a straightforward translation from CFG into LLVM IR

module CodeGen.LLVMGen where

import AST qualified
import CFG (CFG (..), SingleFileCFG (..))
import CFG qualified
import CodeGen.LLVMIR
import Control.Lens ((^.))
import Control.Monad.Except
import Control.Monad.State
import Data.Functor ((<&>))
import Data.Generics.Labels
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Char (ord)
import SSA (SSA)
import SSA qualified
import Types (BBID, CompileError (CompileError), Name)
import Util.Graph qualified as G
import Data.Maybe (fromMaybe)
import qualified Data.Map as Map
import Formatting
import Data.List (sort, sortBy, sortOn)

data LLVMGenState = LLVMGenState

newtype LLVMGen a = LLVMGen
  { forall a. LLVMGen a -> ExceptT CompileError (State LLVMGenState) a
runLLVMGen ::
      ExceptT
        CompileError
        (State LLVMGenState)
        a
  }
  deriving
    ((forall a b. (a -> b) -> LLVMGen a -> LLVMGen b)
-> (forall a b. a -> LLVMGen b -> LLVMGen a) -> Functor LLVMGen
forall a b. a -> LLVMGen b -> LLVMGen a
forall a b. (a -> b) -> LLVMGen a -> LLVMGen b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> LLVMGen a -> LLVMGen b
fmap :: forall a b. (a -> b) -> LLVMGen a -> LLVMGen b
$c<$ :: forall a b. a -> LLVMGen b -> LLVMGen a
<$ :: forall a b. a -> LLVMGen b -> LLVMGen a
Functor, Functor LLVMGen
Functor LLVMGen
-> (forall a. a -> LLVMGen a)
-> (forall a b. LLVMGen (a -> b) -> LLVMGen a -> LLVMGen b)
-> (forall a b c.
    (a -> b -> c) -> LLVMGen a -> LLVMGen b -> LLVMGen c)
-> (forall a b. LLVMGen a -> LLVMGen b -> LLVMGen b)
-> (forall a b. LLVMGen a -> LLVMGen b -> LLVMGen a)
-> Applicative LLVMGen
forall a. a -> LLVMGen a
forall a b. LLVMGen a -> LLVMGen b -> LLVMGen a
forall a b. LLVMGen a -> LLVMGen b -> LLVMGen b
forall a b. LLVMGen (a -> b) -> LLVMGen a -> LLVMGen b
forall a b c. (a -> b -> c) -> LLVMGen a -> LLVMGen b -> LLVMGen c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> LLVMGen a
pure :: forall a. a -> LLVMGen a
$c<*> :: forall a b. LLVMGen (a -> b) -> LLVMGen a -> LLVMGen b
<*> :: forall a b. LLVMGen (a -> b) -> LLVMGen a -> LLVMGen b
$cliftA2 :: forall a b c. (a -> b -> c) -> LLVMGen a -> LLVMGen b -> LLVMGen c
liftA2 :: forall a b c. (a -> b -> c) -> LLVMGen a -> LLVMGen b -> LLVMGen c
$c*> :: forall a b. LLVMGen a -> LLVMGen b -> LLVMGen b
*> :: forall a b. LLVMGen a -> LLVMGen b -> LLVMGen b
$c<* :: forall a b. LLVMGen a -> LLVMGen b -> LLVMGen a
<* :: forall a b. LLVMGen a -> LLVMGen b -> LLVMGen a
Applicative, Applicative LLVMGen
Applicative LLVMGen
-> (forall a b. LLVMGen a -> (a -> LLVMGen b) -> LLVMGen b)
-> (forall a b. LLVMGen a -> LLVMGen b -> LLVMGen b)
-> (forall a. a -> LLVMGen a)
-> Monad LLVMGen
forall a. a -> LLVMGen a
forall a b. LLVMGen a -> LLVMGen b -> LLVMGen b
forall a b. LLVMGen a -> (a -> LLVMGen b) -> LLVMGen b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. LLVMGen a -> (a -> LLVMGen b) -> LLVMGen b
>>= :: forall a b. LLVMGen a -> (a -> LLVMGen b) -> LLVMGen b
$c>> :: forall a b. LLVMGen a -> LLVMGen b -> LLVMGen b
>> :: forall a b. LLVMGen a -> LLVMGen b -> LLVMGen b
$creturn :: forall a. a -> LLVMGen a
return :: forall a. a -> LLVMGen a
Monad, MonadError CompileError, MonadState LLVMGenState)

varName :: SSA.Var -> Text
varName :: Var -> Text
varName Var
var = String -> Text
Text.pack (Var -> String
forall a. Show a => a -> String
show Var
var)

convertType :: AST.Type -> Type
convertType :: Type -> Type
convertType Type
AST.Void = Type
VoidType
convertType Type
AST.BoolType = Int -> Type
IntType Int
1
convertType Type
AST.CharType = Int -> Type
IntType Int
8
convertType Type
AST.IntType = Int -> Type
IntType Int
64
convertType Type
AST.StringType = Type -> Type
PointerType (Int -> Type
IntType Int
8)
convertType (AST.ArrayType Type
tpe Int64
len) = Type -> Int -> Type
ArrayType (Type -> Type
convertType Type
tpe) (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
len)
convertType (AST.Ptr Type
tpe) = Type -> Type
PointerType (Type -> Type
convertType Type
tpe)

genLLVMIR :: SingleFileCFG -> LLVMGen Module
genLLVMIR :: SingleFileCFG -> LLVMGen Module
genLLVMIR (SingleFileCFG [Text]
declares [(Var, Type)]
globals Map Text CFG
cfgs) = do
  [Declare]
declares' <- [Text] -> LLVMGen [Declare]
genExternalDeclares [Text]
declares
  [Global]
globals' <- [(Var, Type)] -> LLVMGen [Global]
genGlobals [(Var, Type)]
globals
  [Function]
functions <- (CFG -> LLVMGen Function)
-> Map Text CFG -> LLVMGen (Map Text Function)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Map Text a -> m (Map Text b)
mapM CFG -> LLVMGen Function
genFunction Map Text CFG
cfgs LLVMGen (Map Text Function)
-> (Map Text Function -> [Function]) -> LLVMGen [Function]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Map Text Function -> [Function]
forall k a. Map k a -> [a]
Map.elems
  Module -> LLVMGen Module
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Module -> LLVMGen Module) -> Module -> LLVMGen Module
forall a b. (a -> b) -> a -> b
$ [Declare] -> [Global] -> [Function] -> Module
Module [Declare]
declares' [Global]
globals' [Function]
functions

genExternalDeclares :: [Name] -> LLVMGen [Declare]
genExternalDeclares :: [Text] -> LLVMGen [Declare]
genExternalDeclares = (Text -> LLVMGen Declare) -> [Text] -> LLVMGen [Declare]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Text -> LLVMGen Declare) -> [Text] -> LLVMGen [Declare])
-> (Text -> LLVMGen Declare) -> [Text] -> LLVMGen [Declare]
forall a b. (a -> b) -> a -> b
$ Declare -> LLVMGen Declare
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Declare -> LLVMGen Declare)
-> (Text -> Declare) -> Text -> LLVMGen Declare
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Declare
Declare

genGlobals :: [(SSA.Var, AST.Type)] -> LLVMGen [Global]
genGlobals :: [(Var, Type)] -> LLVMGen [Global]
genGlobals = ((Var, Type) -> LLVMGen Global)
-> [(Var, Type)] -> LLVMGen [Global]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (((Var, Type) -> LLVMGen Global)
 -> [(Var, Type)] -> LLVMGen [Global])
-> ((Var, Type) -> LLVMGen Global)
-> [(Var, Type)]
-> LLVMGen [Global]
forall a b. (a -> b) -> a -> b
$ \(Var
var, Type
tpe) -> Global -> LLVMGen Global
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Global -> LLVMGen Global) -> Global -> LLVMGen Global
forall a b. (a -> b) -> a -> b
$ Text -> Type -> Global
Global (Var -> Text
varName Var
var) (Type -> Type
convertType Type
tpe)

genFunction :: CFG -> LLVMGen Function
genFunction :: CFG -> LLVMGen Function
genFunction cfg :: CFG
cfg@(CFG Graph Int BasicBlock CFGEdge
g Int
_ Int
_ [Var]
args MethodSig
sig) = do
  let name :: Text
name = MethodSig
sig MethodSig -> Getting Text MethodSig Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text MethodSig Text
#name
  let arguments :: [Argument]
arguments = [Var]
args [Var] -> (Var -> Argument) -> [Argument]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Var -> Argument
genArgument
  [BasicBlock]
bbs <- CFG -> LLVMGen [BasicBlock]
genCFG CFG
cfg
  let retTpe :: Type
retTpe = Type -> (Type -> Type) -> Maybe Type -> Type
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Type
VoidType Type -> Type
convertType (MethodSig
sig MethodSig
-> Getting (Maybe Type) MethodSig (Maybe Type) -> Maybe Type
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Type) MethodSig (Maybe Type)
#tpe)
  Function -> LLVMGen Function
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Function -> LLVMGen Function) -> Function -> LLVMGen Function
forall a b. (a -> b) -> a -> b
$ Text -> Type -> [Argument] -> [BasicBlock] -> Function
Function Text
name Type
retTpe [Argument]
arguments [BasicBlock]
bbs

genArgument :: SSA.Var -> Argument
genArgument :: Var -> Argument
genArgument Var
var = Text -> Type -> Argument
Argument (Var -> Text
varName Var
var) (Type -> Type
convertType (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Var
var Var -> Getting Type Var Type -> Type
forall s a. s -> Getting a s a -> a
^. Getting Type Var Type
#tpe)

genCFG :: CFG -> LLVMGen [BasicBlock]
genCFG :: CFG -> LLVMGen [BasicBlock]
genCFG cfg :: CFG
cfg@(CFG Graph Int BasicBlock CFGEdge
g Int
_ Int
_ [Var]
_ MethodSig
_) = do
  let nodes :: [(Int, BasicBlock)]
nodes = ((Int, BasicBlock) -> Int)
-> [(Int, BasicBlock)] -> [(Int, BasicBlock)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Int, BasicBlock) -> Int
forall a b. (a, b) -> a
fst (Graph Int BasicBlock CFGEdge -> [(Int, BasicBlock)]
forall ni nd ed. (Eq ni, Ord ni) => Graph ni nd ed -> [(ni, nd)]
G.nodeToList Graph Int BasicBlock CFGEdge
g)
  ((Int, BasicBlock) -> LLVMGen BasicBlock)
-> [(Int, BasicBlock)] -> LLVMGen [BasicBlock]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Int -> BasicBlock -> LLVMGen BasicBlock)
-> (Int, BasicBlock) -> LLVMGen BasicBlock
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Int -> BasicBlock -> LLVMGen BasicBlock)
 -> (Int, BasicBlock) -> LLVMGen BasicBlock)
-> (Int -> BasicBlock -> LLVMGen BasicBlock)
-> (Int, BasicBlock)
-> LLVMGen BasicBlock
forall a b. (a -> b) -> a -> b
$ CFG -> Int -> BasicBlock -> LLVMGen BasicBlock
genBasicBlock CFG
cfg) [(Int, BasicBlock)]
nodes

genBasicBlock :: CFG -> BBID -> CFG.BasicBlock -> LLVMGen BasicBlock
genBasicBlock :: CFG -> Int -> BasicBlock -> LLVMGen BasicBlock
genBasicBlock (CFG Graph Int BasicBlock CFGEdge
g Int
_ Int
exit [Var]
_ MethodSig
_) Int
id BasicBlock
b = do
  [Instruction]
insts <- (SSA -> LLVMGen [Instruction]) -> [SSA] -> LLVMGen [[Instruction]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM SSA -> LLVMGen [Instruction]
genInstruction (BasicBlock
b BasicBlock -> Getting [SSA] BasicBlock [SSA] -> [SSA]
forall s a. s -> Getting a s a -> a
^. Getting [SSA] BasicBlock [SSA]
#statements) LLVMGen [[Instruction]]
-> ([[Instruction]] -> [Instruction]) -> LLVMGen [Instruction]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> [[Instruction]] -> [Instruction]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  let outEdges :: [(Int, Int, CFGEdge)]
outEdges = Int -> Graph Int BasicBlock CFGEdge -> [(Int, Int, CFGEdge)]
forall ni nd ed.
(Eq ni, Ord ni) =>
ni -> Graph ni nd ed -> [(ni, ni, ed)]
G.outBound Int
id Graph Int BasicBlock CFGEdge
g
  [TermInst]
br <- case [(Int, Int, CFGEdge)]
outEdges of
    [] -> [TermInst] -> LLVMGen [TermInst]
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    [(Int
_, Int
dst, CFGEdge
CFG.SeqEdge)] -> [TermInst] -> LLVMGen [TermInst]
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return [Label -> TermInst
BrUncon (Label -> TermInst) -> Label -> TermInst
forall a b. (a -> b) -> a -> b
$ Int -> Label
Label Int
dst]
    [(Int
_, Int
dst1, CFG.CondEdge (CFG.Pred VarOrImm
var)), (Int
_, Int
dst2, CFG.CondEdge (CFG.Complement VarOrImm
_))] -> do
      Value
pred <- VarOrImm -> LLVMGen Value
genImmOrVar VarOrImm
var
      [TermInst] -> LLVMGen [TermInst]
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return [Value -> Label -> Label -> TermInst
BrCon Value
pred (Int -> Label
Label Int
dst1) (Int -> Label
Label Int
dst2)]
    [(Int
_, Int
dst1, CFG.CondEdge (CFG.Complement VarOrImm
var)), (Int
_, Int
dst2, CFG.CondEdge (CFG.Pred VarOrImm
_))] -> do
      Value
pred <- VarOrImm -> LLVMGen Value
genImmOrVar VarOrImm
var
      [TermInst] -> LLVMGen [TermInst]
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return [Value -> Label -> Label -> TermInst
BrCon Value
pred (Int -> Label
Label Int
dst2) (Int -> Label
Label Int
dst1)]
    [(Int, Int, CFGEdge)]
edges -> CompileError -> LLVMGen [TermInst]
forall a. CompileError -> LLVMGen a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> LLVMGen [TermInst])
-> CompileError -> LLVMGen [TermInst]
forall a b. (a -> b) -> a -> b
$ Maybe Range -> Text -> CompileError
CompileError Maybe Range
forall a. Maybe a
Nothing (Format Text ([(Int, Int, CFGEdge)] -> Text)
-> [(Int, Int, CFGEdge)] -> Text
forall a. Format Text a -> a
sformat (Format
  ([(Int, Int, CFGEdge)] -> Text) ([(Int, Int, CFGEdge)] -> Text)
"Unsupported out bound edge of basicblock: " Format
  ([(Int, Int, CFGEdge)] -> Text) ([(Int, Int, CFGEdge)] -> Text)
-> Format Text ([(Int, Int, CFGEdge)] -> Text)
-> Format Text ([(Int, Int, CFGEdge)] -> Text)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Text ([(Int, Int, CFGEdge)] -> Text)
forall a r. Show a => Format r (a -> r)
shown) [(Int, Int, CFGEdge)]
edges)
  BasicBlock -> LLVMGen BasicBlock
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return (BasicBlock -> LLVMGen BasicBlock)
-> BasicBlock -> LLVMGen BasicBlock
forall a b. (a -> b) -> a -> b
$ Label -> [Instruction] -> BasicBlock
BasicBlock (Int -> Label
Label Int
id) ([Instruction] -> BasicBlock) -> [Instruction] -> BasicBlock
forall a b. (a -> b) -> a -> b
$ [Instruction]
insts [Instruction] -> [Instruction] -> [Instruction]
forall a. [a] -> [a] -> [a]
++ ([TermInst]
br [TermInst] -> (TermInst -> Instruction) -> [Instruction]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> TermInst -> Instruction
Terminator)

genImmOrVar :: SSA.VarOrImm -> LLVMGen Value
genImmOrVar :: VarOrImm -> LLVMGen Value
genImmOrVar (SSA.BoolImm Bool
True) = Value -> LLVMGen Value
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> LLVMGen Value) -> Value -> LLVMGen Value
forall a b. (a -> b) -> a -> b
$ Type -> Int64 -> Value
IntImm (Int -> Type
IntType Int
1) Int64
1
genImmOrVar (SSA.BoolImm Bool
False) = Value -> LLVMGen Value
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> LLVMGen Value) -> Value -> LLVMGen Value
forall a b. (a -> b) -> a -> b
$ Type -> Int64 -> Value
IntImm (Int -> Type
IntType Int
1) Int64
0
genImmOrVar (SSA.IntImm Int64
val) = Value -> LLVMGen Value
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> LLVMGen Value) -> Value -> LLVMGen Value
forall a b. (a -> b) -> a -> b
$ Type -> Int64 -> Value
IntImm (Int -> Type
IntType Int
64) Int64
val
genImmOrVar (SSA.CharImm Char
val) = Value -> LLVMGen Value
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> LLVMGen Value) -> Value -> LLVMGen Value
forall a b. (a -> b) -> a -> b
$ Type -> Int64 -> Value
IntImm (Int -> Type
IntType Int
4) (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int64) -> Int -> Int64
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
val)
genImmOrVar (SSA.StringImm Text
val) = CompileError -> LLVMGen Value
forall a. CompileError -> LLVMGen a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> LLVMGen Value) -> CompileError -> LLVMGen Value
forall a b. (a -> b) -> a -> b
$ Maybe Range -> Text -> CompileError
CompileError Maybe Range
forall a. Maybe a
Nothing Text
"LLVM IR shall not contain any unhandled string literal."
genImmOrVar (SSA.Variable Var
var) = Value -> LLVMGen Value
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> LLVMGen Value) -> Value -> LLVMGen Value
forall a b. (a -> b) -> a -> b
$ Var -> Value
Variable (Var -> Value) -> Var -> Value
forall a b. (a -> b) -> a -> b
$ Var -> Var
genVar Var
var

genVar :: SSA.Var -> Var
genVar :: Var -> Var
genVar Var
var = Int -> Type -> Range -> Var
Var (Var
var Var -> Getting Int Var Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int Var Int
#id) (Type -> Type
convertType (Var
var Var -> Getting Type Var Type -> Type
forall s a. s -> Getting a s a -> a
^. Getting Type Var Type
#tpe)) (Var
var Var -> Getting Range Var Range -> Range
forall s a. s -> Getting a s a -> a
^. Getting Range Var Range
#loc)

genInstruction :: SSA -> LLVMGen [Instruction]
genInstruction :: SSA -> LLVMGen [Instruction]
genInstruction (SSA.Assignment Var
result VarOrImm
value) = do
  let res :: Var
res = Var -> Var
genVar Var
result
  Value
val <- VarOrImm -> LLVMGen Value
genImmOrVar VarOrImm
value
  [Instruction] -> LLVMGen [Instruction]
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return [Var -> Value -> Instruction
Assignment Var
res Value
val]
genInstruction (SSA.MethodCall Var
dst Text
name [Var]
args) = do
  let res :: Var
res = Var -> Var
genVar Var
dst
  let args' :: [Value]
args' = [Var]
args [Var] -> (Var -> Value) -> [Value]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Var -> Value
Variable (Var -> Value) -> (Var -> Var) -> Var -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Var -> Var
genVar
  let tpe :: Type
tpe = Type -> Type
convertType (Var
dst Var -> Getting Type Var Type -> Type
forall s a. s -> Getting a s a -> a
^. Getting Type Var Type
#tpe)
  [Instruction] -> LLVMGen [Instruction]
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return [Var -> Type -> Text -> [Value] -> Instruction
Call Var
res Type
tpe Text
name [Value]
args']
genInstruction (SSA.Return Maybe VarOrImm
Nothing) = do
  [Instruction] -> LLVMGen [Instruction]
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return [TermInst -> Instruction
Terminator (TermInst -> Instruction) -> TermInst -> Instruction
forall a b. (a -> b) -> a -> b
$ Maybe Value -> Type -> TermInst
Ret Maybe Value
forall a. Maybe a
Nothing Type
VoidType]
genInstruction (SSA.Return (Just VarOrImm
val)) = do
  Value
val' <- VarOrImm -> LLVMGen Value
genImmOrVar VarOrImm
val 
  [Instruction] -> LLVMGen [Instruction]
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return [TermInst -> Instruction
Terminator (TermInst -> Instruction) -> TermInst -> Instruction
forall a b. (a -> b) -> a -> b
$ Maybe Value -> Type -> TermInst
Ret (Value -> Maybe Value
forall a. a -> Maybe a
Just Value
val') (Value -> Type
valueType Value
val')]
genInstruction (SSA.Alloca Var
dst Type
tpe Maybe Int64
sz) = do
  let res :: Var
res = Var -> Var
genVar Var
dst
  let tpe' :: Type
tpe' = Type -> Type
convertType Type
tpe
  let sz' :: Int64
sz' = Int64 -> Maybe Int64 -> Int64
forall a. a -> Maybe a -> a
fromMaybe Int64
1 Maybe Int64
sz
  [Instruction] -> LLVMGen [Instruction]
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return [MemAccInst -> Instruction
MemAccess (MemAccInst -> Instruction) -> MemAccInst -> Instruction
forall a b. (a -> b) -> a -> b
$ Var -> Type -> Int64 -> MemAccInst
Alloca Var
res Type
tpe' Int64
sz']
genInstruction (SSA.Load Var
dst VarOrImm
ptr) = do
  let res :: Var
res = Var -> Var
genVar Var
dst
  Value
ptr' <- VarOrImm -> LLVMGen Value
genImmOrVar VarOrImm
ptr
  let tpe :: Type
tpe = Type -> Type
convertType (Var
dst Var -> Getting Type Var Type -> Type
forall s a. s -> Getting a s a -> a
^. Getting Type Var Type
#tpe)
  [Instruction] -> LLVMGen [Instruction]
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return [MemAccInst -> Instruction
MemAccess (MemAccInst -> Instruction) -> MemAccInst -> Instruction
forall a b. (a -> b) -> a -> b
$ Var -> Type -> Value -> MemAccInst
Load Var
res Type
tpe Value
ptr']
genInstruction (SSA.Store VarOrImm
ptr VarOrImm
src) = do
  Value
src' <- VarOrImm -> LLVMGen Value
genImmOrVar VarOrImm
src
  Value
res <- VarOrImm -> LLVMGen Value
genImmOrVar VarOrImm
ptr
  [Instruction] -> LLVMGen [Instruction]
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return [MemAccInst -> Instruction
MemAccess (MemAccInst -> Instruction) -> MemAccInst -> Instruction
forall a b. (a -> b) -> a -> b
$ Type -> Value -> Value -> MemAccInst
Store (Value -> Type
valueType Value
src') Value
src' Value
res]
genInstruction (SSA.Arith Var
dst ArithOp
op VarOrImm
opl VarOrImm
opr) = do
  let res :: Var
res = Var -> Var
genVar Var
dst
  let tpe :: Type
tpe = Type -> Type
convertType (Var
dst Var -> Getting Type Var Type -> Type
forall s a. s -> Getting a s a -> a
^. Getting Type Var Type
#tpe)
  Value
opl' <- VarOrImm -> LLVMGen Value
genImmOrVar VarOrImm
opl
  Value
opr' <- VarOrImm -> LLVMGen Value
genImmOrVar VarOrImm
opr
  case ArithOp
op of
    ArithOp
AST.Plus -> [Instruction] -> LLVMGen [Instruction]
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return [BinaryInst -> Instruction
Binary (BinaryInst -> Instruction) -> BinaryInst -> Instruction
forall a b. (a -> b) -> a -> b
$ Var -> Type -> Value -> Value -> BinaryInst
Add Var
res Type
tpe Value
opl' Value
opr']
    ArithOp
AST.Minus -> [Instruction] -> LLVMGen [Instruction]
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return [BinaryInst -> Instruction
Binary (BinaryInst -> Instruction) -> BinaryInst -> Instruction
forall a b. (a -> b) -> a -> b
$ Var -> Type -> Value -> Value -> BinaryInst
Sub Var
res Type
tpe Value
opl' Value
opr']
    ArithOp
AST.Multiply -> [Instruction] -> LLVMGen [Instruction]
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return [BinaryInst -> Instruction
Binary (BinaryInst -> Instruction) -> BinaryInst -> Instruction
forall a b. (a -> b) -> a -> b
$ Var -> Type -> Value -> Value -> BinaryInst
Mul Var
res Type
tpe Value
opl' Value
opr']
    ArithOp
AST.Division -> [Instruction] -> LLVMGen [Instruction]
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return [BinaryInst -> Instruction
Binary (BinaryInst -> Instruction) -> BinaryInst -> Instruction
forall a b. (a -> b) -> a -> b
$ Var -> Type -> Value -> Value -> BinaryInst
SDiv Var
res Type
tpe Value
opl' Value
opr']
genInstruction (SSA.Rel Var
dst RelOp
op VarOrImm
opl VarOrImm
opr) = do
  let res :: Var
res = Var -> Var
genVar Var
dst
  let tpe :: Type
tpe = Type -> Type
convertType (Var
dst Var -> Getting Type Var Type -> Type
forall s a. s -> Getting a s a -> a
^. Getting Type Var Type
#tpe)
  Value
opl' <- VarOrImm -> LLVMGen Value
genImmOrVar VarOrImm
opl
  Value
opr' <- VarOrImm -> LLVMGen Value
genImmOrVar VarOrImm
opr
  case RelOp
op of 
    RelOp
AST.LessThan -> [Instruction] -> LLVMGen [Instruction]
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return [Var -> CondCodes -> Type -> Value -> Value -> Instruction
ICmp Var
res CondCodes
SLT Type
tpe Value
opl' Value
opr']
    RelOp
AST.GreaterThan -> [Instruction] -> LLVMGen [Instruction]
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return [Var -> CondCodes -> Type -> Value -> Value -> Instruction
ICmp Var
res CondCodes
SGT Type
tpe Value
opl' Value
opr']
    RelOp
AST.LessEqual -> [Instruction] -> LLVMGen [Instruction]
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return [Var -> CondCodes -> Type -> Value -> Value -> Instruction
ICmp Var
res CondCodes
SLE Type
tpe Value
opl' Value
opr']
    RelOp
AST.GreaterEqual -> [Instruction] -> LLVMGen [Instruction]
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return [Var -> CondCodes -> Type -> Value -> Value -> Instruction
ICmp Var
res CondCodes
SGE Type
tpe Value
opl' Value
opr']
genInstruction (SSA.Cond Var
dst CondOp
op VarOrImm
opl VarOrImm
opr) = do
  let res :: Var
res = Var -> Var
genVar Var
dst
  let tpe :: Type
tpe = Type -> Type
convertType (Var
dst Var -> Getting Type Var Type -> Type
forall s a. s -> Getting a s a -> a
^. Getting Type Var Type
#tpe)
  Value
opl' <- VarOrImm -> LLVMGen Value
genImmOrVar VarOrImm
opl
  Value
opr' <- VarOrImm -> LLVMGen Value
genImmOrVar VarOrImm
opr
  case CondOp
op of 
    CondOp
AST.And -> [Instruction] -> LLVMGen [Instruction]
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return [BitwiseBinaryInst -> Instruction
BitBinary (BitwiseBinaryInst -> Instruction)
-> BitwiseBinaryInst -> Instruction
forall a b. (a -> b) -> a -> b
$ Var -> Type -> Value -> Value -> BitwiseBinaryInst
And Var
res Type
tpe Value
opl' Value
opr']
    CondOp
AST.Or -> [Instruction] -> LLVMGen [Instruction]
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return [BitwiseBinaryInst -> Instruction
BitBinary (BitwiseBinaryInst -> Instruction)
-> BitwiseBinaryInst -> Instruction
forall a b. (a -> b) -> a -> b
$ Var -> Type -> Value -> Value -> BitwiseBinaryInst
Or Var
res Type
tpe Value
opl' Value
opr']
genInstruction (SSA.Eq Var
dst EqOp
op VarOrImm
opl VarOrImm
opr) = do
  let res :: Var
res = Var -> Var
genVar Var
dst
  let tpe :: Type
tpe = Type -> Type
convertType (Var
dst Var -> Getting Type Var Type -> Type
forall s a. s -> Getting a s a -> a
^. Getting Type Var Type
#tpe)
  Value
opl' <- VarOrImm -> LLVMGen Value
genImmOrVar VarOrImm
opl
  Value
opr' <- VarOrImm -> LLVMGen Value
genImmOrVar VarOrImm
opr
  case EqOp
op of
    EqOp
AST.Equal -> [Instruction] -> LLVMGen [Instruction]
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return [Var -> CondCodes -> Type -> Value -> Value -> Instruction
ICmp Var
res CondCodes
EQL Type
tpe Value
opl' Value
opr']
    EqOp
AST.NotEqual -> [Instruction] -> LLVMGen [Instruction]
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return [Var -> CondCodes -> Type -> Value -> Value -> Instruction
ICmp Var
res CondCodes
NEQ Type
tpe Value
opl' Value
opr']
genInstruction (SSA.Neg Var
dst NegOp
op VarOrImm
opd) = do
  let res :: Var
res = Var -> Var
genVar Var
dst
  let tpe :: Type
tpe = Type -> Type
convertType (Var
dst Var -> Getting Type Var Type -> Type
forall s a. s -> Getting a s a -> a
^. Getting Type Var Type
#tpe)
  Value
zero <- VarOrImm -> LLVMGen Value
genImmOrVar (Int64 -> VarOrImm
SSA.IntImm Int64
0)
  Value
opd' <- VarOrImm -> LLVMGen Value
genImmOrVar VarOrImm
opd
  [Instruction] -> LLVMGen [Instruction]
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return [BinaryInst -> Instruction
Binary (BinaryInst -> Instruction) -> BinaryInst -> Instruction
forall a b. (a -> b) -> a -> b
$ Var -> Type -> Value -> Value -> BinaryInst
Sub Var
res Type
tpe Value
zero Value
opd']
genInstruction (SSA.Not Var
dst NotOp
op VarOrImm
opd) = do
  let res :: Var
res = Var -> Var
genVar Var
dst
  let tpe :: Type
tpe = Type -> Type
convertType (Var
dst Var -> Getting Type Var Type -> Type
forall s a. s -> Getting a s a -> a
^. Getting Type Var Type
#tpe)
  let true :: Value
true = Type -> Int64 -> Value
IntImm (Int -> Type
IntType Int
1) Int64
1
  Value
opd' <- VarOrImm -> LLVMGen Value
genImmOrVar VarOrImm
opd
  [Instruction] -> LLVMGen [Instruction]
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return [BinaryInst -> Instruction
Binary (BinaryInst -> Instruction) -> BinaryInst -> Instruction
forall a b. (a -> b) -> a -> b
$ Var -> Type -> Value -> Value -> BinaryInst
Sub Var
res Type
tpe Value
true Value
opd']
genInstruction (SSA.Phi Var
dst [(Var, Int)]
preds) = do
  let res :: Var
res = Var -> Var
genVar Var
dst
  let tpe :: Type
tpe = Type -> Type
convertType (Var
dst Var -> Getting Type Var Type -> Type
forall s a. s -> Getting a s a -> a
^. Getting Type Var Type
#tpe)
  let preds' :: [(Var, Label)]
preds' = [(Var, Int)]
preds [(Var, Int)] -> ((Var, Int) -> (Var, Label)) -> [(Var, Label)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Var
var, Int
label) ->
        let var' :: Var
var' = Var -> Var
genVar Var
var
        in (Var
var', Int -> Label
Label Int
label)
  [Instruction] -> LLVMGen [Instruction]
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return [Var -> Type -> [(Var, Label)] -> Instruction
Phi Var
res Type
tpe [(Var, Label)]
preds']
genInstruction (SSA.AllocaStr Var
dst Text
content Type
tpe) = do
  let res :: Var
res = Var -> Var
genVar Var
dst
  Int64
sz <- case Type
tpe of
    AST.ArrayType Type
_ Int64
sz' -> Int64 -> LLVMGen Int64
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return Int64
sz'
    Type
_ -> CompileError -> LLVMGen Int64
forall a. CompileError -> LLVMGen a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> LLVMGen Int64) -> CompileError -> LLVMGen Int64
forall a b. (a -> b) -> a -> b
$ Maybe Range -> Text -> CompileError
CompileError Maybe Range
forall a. Maybe a
Nothing Text
"String should have array type."
  let charType :: Type
charType = Type -> Type
convertType Type
AST.CharType
  let alloca :: Instruction
alloca = MemAccInst -> Instruction
MemAccess (MemAccInst -> Instruction) -> MemAccInst -> Instruction
forall a b. (a -> b) -> a -> b
$ Var -> Type -> Int64 -> MemAccInst
Alloca Var
res Type
charType Int64
sz
  let tpe' :: Type
tpe' = Type -> Type
convertType Type
tpe
  let stores :: [(Type, Value)]
stores = Text -> String
Text.unpack Text
content String -> (Char -> (Type, Value)) -> [(Type, Value)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Char
c -> (Type
charType, Type -> Int64 -> Value
IntImm Type
charType (Int64 -> Value) -> Int64 -> Value
forall a b. (a -> b) -> a -> b
$ Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int64) -> Int -> Int64
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
c)
  [Instruction] -> LLVMGen [Instruction]
forall a. a -> LLVMGen a
forall (m :: * -> *) a. Monad m => a -> m a
return [Instruction
alloca, MemAccInst -> Instruction
MemAccess (MemAccInst -> Instruction) -> MemAccInst -> Instruction
forall a b. (a -> b) -> a -> b
$ Type -> [(Type, Value)] -> Value -> MemAccInst
StoreVec Type
tpe' [(Type, Value)]
stores (Var -> Value
Variable Var
res)]
genInstruction SSA
inst =
  CompileError -> LLVMGen [Instruction]
forall a. CompileError -> LLVMGen a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> LLVMGen [Instruction])
-> CompileError -> LLVMGen [Instruction]
forall a b. (a -> b) -> a -> b
$ Maybe Range -> Text -> CompileError
CompileError Maybe Range
forall a. Maybe a
Nothing (Format Text (SSA -> Text) -> SSA -> Text
forall a. Format Text a -> a
sformat (Format (SSA -> Text) (SSA -> Text)
"Unhandled SSA Instruction:" Format (SSA -> Text) (SSA -> Text)
-> Format Text (SSA -> Text) -> Format Text (SSA -> Text)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format Text (SSA -> Text)
forall a r. Show a => Format r (a -> r)
shown) SSA
inst)