{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE TupleSections #-}

module CodeGen.Llvm.LlvmIrGen (ppLlvmModule, genLlvmIrModule) where

import CodeGen.Module (Module (Module))
import Control.Monad.State (MonadState, State, evalState, gets, modify)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.String.Conversions (cs)
import Data.Text (Text)
import qualified Data.Text as Txt
import Foreign (fromBool)
import qualified LLVM.Codegen as LLVM
import MonadUtils (locally)
import qualified StdLib
import Transformations.Anf.Anf
import Trees.Common

-- * LLVM Code Generation

genLlvmIrModule :: Module -> LLVM.Module
genLlvmIrModule :: Module -> Module
genLlvmIrModule = Module -> Module
genModule

ppLlvmModule :: LLVM.Module -> Text
ppLlvmModule :: Module -> Identifier
ppLlvmModule = Identifier -> Identifier
forall a b. ConvertibleStrings a b => a -> b
cs (Identifier -> Identifier)
-> (Module -> Identifier) -> Module -> Identifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> Identifier
LLVM.ppllvm

-- * Implementation

type CodeGenM = LLVM.IRBuilderT Llvm

type Llvm = LLVM.ModuleBuilderT (State Env)

data Env = Env
  { Env -> Map Identifier' Operand
locVars :: Map Identifier' LLVM.Operand,
    Env -> Map Identifier' Operand
globVars :: Map Identifier' LLVM.Operand,
    Env -> Map Identifier' (Operand, Arity)
funs :: Map Identifier' (LLVM.Operand, Arity)
  }

genModule :: Module -> LLVM.Module
genModule :: Module -> Module
genModule (Module (Program [GlobalDeclaration]
decls)) = (State Env Module -> Env -> Module)
-> Env -> State Env Module -> Module
forall a b c. (a -> b -> c) -> b -> a -> c
flip State Env Module -> Env -> Module
forall s a. State s a -> s -> a
evalState (Map Identifier' Operand
-> Map Identifier' Operand
-> Map Identifier' (Operand, Arity)
-> Env
Env Map Identifier' Operand
forall k a. Map k a
Map.empty Map Identifier' Operand
forall k a. Map k a
Map.empty Map Identifier' (Operand, Arity)
forall k a. Map k a
Map.empty) (State Env Module -> Module) -> State Env Module -> Module
forall a b. (a -> b) -> a -> b
$
  ModuleBuilderT (StateT Env Identity) Operand -> State Env Module
forall (m :: * -> *) a. Monad m => ModuleBuilderT m a -> m Module
LLVM.runModuleBuilderT (ModuleBuilderT (StateT Env Identity) Operand -> State Env Module)
-> ModuleBuilderT (StateT Env Identity) Operand -> State Env Module
forall a b. (a -> b) -> a -> b
$ do
    (DeclarationWithArity -> ModuleBuilderT (StateT Env Identity) ())
-> [DeclarationWithArity]
-> ModuleBuilderT (StateT Env Identity) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ DeclarationWithArity -> ModuleBuilderT (StateT Env Identity) ()
genStdLibDecl [DeclarationWithArity]
StdLib.allDeclsWithArity
    (GlobalDeclaration -> ModuleBuilderT (StateT Env Identity) ())
-> [GlobalDeclaration] -> ModuleBuilderT (StateT Env Identity) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ GlobalDeclaration -> ModuleBuilderT (StateT Env Identity) ()
genGlobDecl [GlobalDeclaration]
decls

    -- In the `main` we define our global variables.
    Name
-> [(Type, ParameterName)]
-> Type
-> ([Operand] -> IRBuilderT Llvm ())
-> ModuleBuilderT (StateT Env Identity) Operand
forall (m :: * -> *) a.
(HasCallStack, MonadModuleBuilder m) =>
Name
-> [(Type, ParameterName)]
-> Type
-> ([Operand] -> IRBuilderT m a)
-> m Operand
LLVM.function Name
"main" [] Type
LLVM.i64 (([Operand] -> IRBuilderT Llvm ())
 -> ModuleBuilderT (StateT Env Identity) Operand)
-> ([Operand] -> IRBuilderT Llvm ())
-> ModuleBuilderT (StateT Env Identity) Operand
forall a b. (a -> b) -> a -> b
$ \[Operand]
_ -> do
      (GlobalDeclaration -> IRBuilderT Llvm ())
-> [GlobalDeclaration] -> IRBuilderT Llvm ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ GlobalDeclaration -> IRBuilderT Llvm ()
gVarDef [GlobalDeclaration]
decls
      Operand -> IRBuilderT Llvm ()
forall (m :: * -> *).
(HasCallStack, MonadIRBuilder m) =>
Operand -> m ()
LLVM.ret (Integer -> Operand
LLVM.int64 Integer
0)
  where
    gVarDef :: GlobalDeclaration -> CodeGenM ()
    gVarDef :: GlobalDeclaration -> IRBuilderT Llvm ()
gVarDef = \case
      GlobVarDecl Identifier'
ident Expression
value -> do
        Operand
operand <- Identifier' -> IRBuilderT Llvm Operand
forall (m :: * -> *). MonadState Env m => Identifier' -> m Operand
findGlobVar Identifier'
ident
        Operand
value' <- Expression -> IRBuilderT Llvm Operand
genExpr Expression
value
        Operand -> Operand -> IRBuilderT Llvm ()
store' Operand
operand Operand
value'
      GlobalDeclaration
_ -> () -> IRBuilderT Llvm ()
forall a. a -> IRBuilderT Llvm a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

genStdLibDecl :: StdLib.DeclarationWithArity -> Llvm ()
genStdLibDecl :: DeclarationWithArity -> ModuleBuilderT (StateT Env Identity) ()
genStdLibDecl DeclarationWithArity
decl = DeclarationWithArity
-> ModuleBuilderT (StateT Env Identity) Operand
declareAsExtern DeclarationWithArity
decl ModuleBuilderT (StateT Env Identity) Operand
-> (Operand -> ModuleBuilderT (StateT Env Identity) ())
-> ModuleBuilderT (StateT Env Identity) ()
forall a b.
ModuleBuilderT (StateT Env Identity) a
-> (a -> ModuleBuilderT (StateT Env Identity) b)
-> ModuleBuilderT (StateT Env Identity) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DeclarationWithArity
-> Operand -> ModuleBuilderT (StateT Env Identity) ()
register DeclarationWithArity
decl
  where
    declareAsExtern :: StdLib.DeclarationWithArity -> Llvm LLVM.Operand
    declareAsExtern :: DeclarationWithArity
-> ModuleBuilderT (StateT Env Identity) Operand
declareAsExtern (Identifier
ident, Arity
arity) =
      Name
-> [Type] -> Type -> ModuleBuilderT (StateT Env Identity) Operand
forall (m :: * -> *).
MonadModuleBuilder m =>
Name -> [Type] -> Type -> m Operand
LLVM.extern
        (Identifier -> Name
LLVM.Name Identifier
ident)
        (Arity -> Type -> [Type]
forall a. Arity -> a -> [a]
replicate Arity
arity Type
LLVM.i64)
        Type
LLVM.i64

    register :: StdLib.DeclarationWithArity -> LLVM.Operand -> Llvm ()
    register :: DeclarationWithArity
-> Operand -> ModuleBuilderT (StateT Env Identity) ()
register (Identifier
ident, Arity
arity) Operand
fun = Identifier'
-> Operand -> Arity -> ModuleBuilderT (StateT Env Identity) ()
forall (m :: * -> *).
MonadState Env m =>
Identifier' -> Operand -> Arity -> m ()
regFun (Identifier -> Identifier'
Txt Identifier
ident) Operand
fun Arity
arity

genGlobDecl :: GlobalDeclaration -> Llvm ()
genGlobDecl :: GlobalDeclaration -> ModuleBuilderT (StateT Env Identity) ()
genGlobDecl = \case
  GlobVarDecl Identifier'
ident Expression
_ -> do
    Operand
var <- Name
-> Type -> Constant -> ModuleBuilderT (StateT Env Identity) Operand
forall (m :: * -> *).
MonadModuleBuilder m =>
Name -> Type -> Constant -> m Operand
LLVM.global (Identifier -> Name
LLVM.Name (Identifier -> Name) -> Identifier -> Name
forall a b. (a -> b) -> a -> b
$ String -> Identifier
Txt.pack (String -> Identifier) -> String -> Identifier
forall a b. (a -> b) -> a -> b
$ Identifier' -> String
genId Identifier'
ident) Type
LLVM.i64 (Alignment -> Integer -> Constant
LLVM.Int Alignment
64 Integer
0)
    Identifier' -> Operand -> ModuleBuilderT (StateT Env Identity) ()
forall (m :: * -> *).
MonadState Env m =>
Identifier' -> Operand -> m ()
regGlobVar Identifier'
ident Operand
var
  GlobFunDecl Identifier'
ident [Identifier']
params Expression
body -> mdo
    Identifier'
-> Operand -> Arity -> ModuleBuilderT (StateT Env Identity) ()
forall (m :: * -> *).
MonadState Env m =>
Identifier' -> Operand -> Arity -> m ()
regFun Identifier'
ident Operand
fun ([Identifier'] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Identifier']
params)
    Operand
fun <- ModuleBuilderT (StateT Env Identity) Operand
-> ModuleBuilderT (StateT Env Identity) Operand
forall s (m :: * -> *) a. MonadState s m => m a -> m a
locally (ModuleBuilderT (StateT Env Identity) Operand
 -> ModuleBuilderT (StateT Env Identity) Operand)
-> ModuleBuilderT (StateT Env Identity) Operand
-> ModuleBuilderT (StateT Env Identity) Operand
forall a b. (a -> b) -> a -> b
$ do
      Name
-> [(Type, ParameterName)]
-> Type
-> ([Operand] -> IRBuilderT Llvm ())
-> ModuleBuilderT (StateT Env Identity) Operand
forall (m :: * -> *) a.
(HasCallStack, MonadModuleBuilder m) =>
Name
-> [(Type, ParameterName)]
-> Type
-> ([Operand] -> IRBuilderT m a)
-> m Operand
LLVM.function
        (Identifier -> Name
LLVM.Name (Identifier -> Name) -> Identifier -> Name
forall a b. (a -> b) -> a -> b
$ String -> Identifier
Txt.pack (String -> Identifier) -> String -> Identifier
forall a b. (a -> b) -> a -> b
$ Identifier' -> String
genId Identifier'
ident)
        ((Type
LLVM.i64,) (ParameterName -> (Type, ParameterName))
-> (Identifier' -> ParameterName)
-> Identifier'
-> (Type, ParameterName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> ParameterName
LLVM.ParameterName (Identifier -> ParameterName)
-> (Identifier' -> Identifier) -> Identifier' -> ParameterName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Identifier
Txt.pack (String -> Identifier)
-> (Identifier' -> String) -> Identifier' -> Identifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier' -> String
genId (Identifier' -> (Type, ParameterName))
-> [Identifier'] -> [(Type, ParameterName)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Identifier']
params)
        Type
LLVM.i64
        (([Operand] -> IRBuilderT Llvm ())
 -> ModuleBuilderT (StateT Env Identity) Operand)
-> ([Operand] -> IRBuilderT Llvm ())
-> ModuleBuilderT (StateT Env Identity) Operand
forall a b. (a -> b) -> a -> b
$ \[Operand]
args -> do
          ((Identifier', Operand) -> IRBuilderT Llvm ())
-> [(Identifier', Operand)] -> IRBuilderT Llvm ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Identifier' -> Operand -> IRBuilderT Llvm ())
-> (Identifier', Operand) -> IRBuilderT Llvm ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Identifier' -> Operand -> IRBuilderT Llvm ()
forall (m :: * -> *).
MonadState Env m =>
Identifier' -> Operand -> m ()
regLocVar) ([Identifier']
params [Identifier'] -> [Operand] -> [(Identifier', Operand)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Operand]
args)
          Operand
body' <- Expression -> IRBuilderT Llvm Operand
genExpr Expression
body
          Operand -> IRBuilderT Llvm ()
forall (m :: * -> *).
(HasCallStack, MonadIRBuilder m) =>
Operand -> m ()
LLVM.ret Operand
body'
    () -> ModuleBuilderT (StateT Env Identity) ()
forall a. a -> Llvm a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

genId :: Identifier' -> String
genId :: Identifier' -> String
genId = \case
  Txt Identifier
txt -> Identifier -> String
Txt.unpack Identifier
txt
  Gen Integer
n Identifier
txt -> Identifier -> String
Txt.unpack Identifier
txt String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
n

genExpr :: Expression -> CodeGenM LLVM.Operand
genExpr :: Expression -> IRBuilderT Llvm Operand
genExpr = \case
  ExprAtom AtomicExpression
atom -> AtomicExpression -> IRBuilderT Llvm Operand
genAtom AtomicExpression
atom
  ExprComp ComplexExpression
ce -> ComplexExpression -> IRBuilderT Llvm Operand
genComp ComplexExpression
ce
  ExprLetIn (Identifier'
ident, Expression
val) Expression
expr -> do
    Operand
val' <- Expression -> IRBuilderT Llvm Operand
genExpr Expression
val
    Identifier' -> Operand -> IRBuilderT Llvm ()
forall (m :: * -> *).
MonadState Env m =>
Identifier' -> Operand -> m ()
regLocVar Identifier'
ident Operand
val'
    Expression -> IRBuilderT Llvm Operand
genExpr Expression
expr

genAtom :: AtomicExpression -> CodeGenM LLVM.Operand
genAtom :: AtomicExpression -> IRBuilderT Llvm Operand
genAtom = \case
  AtomId Identifier'
ident -> Identifier' -> IRBuilderT Llvm Operand
findAny Identifier'
ident
  AtomicExpression
AtomUnit -> Operand -> IRBuilderT Llvm Operand
forall a. a -> IRBuilderT Llvm a
forall (m :: * -> *) a. Monad m => a -> m a
return (Operand -> IRBuilderT Llvm Operand)
-> Operand -> IRBuilderT Llvm Operand
forall a b. (a -> b) -> a -> b
$ Integer -> Operand
LLVM.int64 Integer
0
  AtomBool Bool
bool -> Operand -> IRBuilderT Llvm Operand
forall a. a -> IRBuilderT Llvm a
forall (m :: * -> *) a. Monad m => a -> m a
return (Operand -> IRBuilderT Llvm Operand)
-> Operand -> IRBuilderT Llvm Operand
forall a b. (a -> b) -> a -> b
$ Integer -> Operand
LLVM.int64 (Integer -> Operand) -> Integer -> Operand
forall a b. (a -> b) -> a -> b
$ Bool -> Integer
forall a. Num a => Bool -> a
fromBool Bool
bool
  AtomInt Int64
int -> Operand -> IRBuilderT Llvm Operand
forall a. a -> IRBuilderT Llvm a
forall (m :: * -> *) a. Monad m => a -> m a
return (Operand -> IRBuilderT Llvm Operand)
-> Operand -> IRBuilderT Llvm Operand
forall a b. (a -> b) -> a -> b
$ Integer -> Operand
LLVM.int64 (Integer -> Operand) -> Integer -> Operand
forall a b. (a -> b) -> a -> b
$ Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger Int64
int

genComp :: ComplexExpression -> CodeGenM LLVM.Operand
genComp :: ComplexExpression -> IRBuilderT Llvm Operand
genComp = \case
  CompApp Identifier'
f AtomicExpression
arg -> do
    Operand
f' <- Identifier' -> IRBuilderT Llvm Operand
findAny Identifier'
f
    Operand
arg' <- AtomicExpression -> IRBuilderT Llvm Operand
genAtom AtomicExpression
arg
    Operand
applyF <- Identifier' -> IRBuilderT Llvm Operand
findFun (Identifier -> Identifier'
Txt Identifier
"miniml_apply")
    Operand -> [Operand] -> IRBuilderT Llvm Operand
forall (m :: * -> *).
(HasCallStack, MonadIRBuilder m) =>
Operand -> [Operand] -> m Operand
LLVM.call Operand
applyF [Operand
f', Operand
arg']
  CompIte AtomicExpression
c Expression
t Expression
e -> mdo
    Operand
rv <- IRBuilderT Llvm Operand
allocate'

    Operand
c' <- AtomicExpression -> IRBuilderT Llvm Operand
genAtom AtomicExpression
c IRBuilderT Llvm Operand
-> (Operand -> IRBuilderT Llvm Operand) -> IRBuilderT Llvm Operand
forall a b.
IRBuilderT Llvm a -> (a -> IRBuilderT Llvm b) -> IRBuilderT Llvm b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Operand -> IRBuilderT Llvm Operand
intToBool
    Operand -> Name -> Name -> IRBuilderT Llvm ()
forall (m :: * -> *).
(HasCallStack, MonadIRBuilder m) =>
Operand -> Name -> Name -> m ()
LLVM.condBr Operand
c' Name
tBlock Name
eBlock

    Name
tBlock <- Identifier -> IRBuilderT Llvm Name
forall (m :: * -> *). MonadIRBuilder m => Identifier -> m Name
LLVM.blockNamed Identifier
"if.then"
    Operand -> Operand -> IRBuilderT Llvm ()
store' Operand
rv (Operand -> IRBuilderT Llvm ())
-> IRBuilderT Llvm Operand -> IRBuilderT Llvm ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Expression -> IRBuilderT Llvm Operand
genExpr Expression
t
    Name -> IRBuilderT Llvm ()
forall (m :: * -> *).
(MonadIRBuilder m, HasCallStack) =>
Name -> m ()
LLVM.br Name
end

    Name
eBlock <- Identifier -> IRBuilderT Llvm Name
forall (m :: * -> *). MonadIRBuilder m => Identifier -> m Name
LLVM.blockNamed Identifier
"if.else"
    Operand -> Operand -> IRBuilderT Llvm ()
store' Operand
rv (Operand -> IRBuilderT Llvm ())
-> IRBuilderT Llvm Operand -> IRBuilderT Llvm ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Expression -> IRBuilderT Llvm Operand
genExpr Expression
e
    Name -> IRBuilderT Llvm ()
forall (m :: * -> *).
(MonadIRBuilder m, HasCallStack) =>
Name -> m ()
LLVM.br Name
end

    Name
end <- Identifier -> IRBuilderT Llvm Name
forall (m :: * -> *). MonadIRBuilder m => Identifier -> m Name
LLVM.blockNamed Identifier
"if.end"

    Operand -> IRBuilderT Llvm Operand
load' Operand
rv
  CompBinOp BinaryOperator
op AtomicExpression
lhs AtomicExpression
rhs -> do
    Operand
lhs' <- AtomicExpression -> IRBuilderT Llvm Operand
genAtom AtomicExpression
lhs
    Operand
rhs' <- AtomicExpression -> IRBuilderT Llvm Operand
genAtom AtomicExpression
rhs
    let opF :: Operand -> Operand -> IRBuilderT Llvm Operand
opF = case BinaryOperator
op of
          BoolOp BooleanOperator
AndOp -> Operand -> Operand -> IRBuilderT Llvm Operand
forall (m :: * -> *).
(MonadIRBuilder m, HasCallStack) =>
Operand -> Operand -> m Operand
LLVM.and
          BoolOp BooleanOperator
OrOp -> Operand -> Operand -> IRBuilderT Llvm Operand
forall (m :: * -> *).
(MonadIRBuilder m, HasCallStack) =>
Operand -> Operand -> m Operand
LLVM.or
          ArithOp ArithmeticOperator
PlusOp -> Operand -> Operand -> IRBuilderT Llvm Operand
forall (m :: * -> *).
(MonadIRBuilder m, HasCallStack) =>
Operand -> Operand -> m Operand
LLVM.add
          ArithOp ArithmeticOperator
MinusOp -> Operand -> Operand -> IRBuilderT Llvm Operand
forall (m :: * -> *).
(MonadIRBuilder m, HasCallStack) =>
Operand -> Operand -> m Operand
LLVM.sub
          ArithOp ArithmeticOperator
MulOp -> Operand -> Operand -> IRBuilderT Llvm Operand
forall (m :: * -> *).
(MonadIRBuilder m, HasCallStack) =>
Operand -> Operand -> m Operand
LLVM.mul
          ArithOp ArithmeticOperator
DivOp -> \Operand
lhs'' Operand
rhs'' -> do
            Operand
divF <- Identifier' -> IRBuilderT Llvm Operand
findFun (Identifier -> Identifier'
Txt Identifier
"miniml_div")
            Operand -> [Operand] -> IRBuilderT Llvm Operand
forall (m :: * -> *).
(HasCallStack, MonadIRBuilder m) =>
Operand -> [Operand] -> m Operand
LLVM.call Operand
divF [Operand
lhs'', Operand
rhs'']
          CompOp ComparisonOperator
cOp ->
            let cOpF :: Operand -> Operand -> IRBuilderT Llvm Operand
cOpF = case ComparisonOperator
cOp of
                  ComparisonOperator
EqOp -> Operand -> Operand -> IRBuilderT Llvm Operand
forall (m :: * -> *).
(MonadIRBuilder m, HasCallStack) =>
Operand -> Operand -> m Operand
LLVM.eq
                  ComparisonOperator
NeOp -> Operand -> Operand -> IRBuilderT Llvm Operand
forall (m :: * -> *).
(MonadIRBuilder m, HasCallStack) =>
Operand -> Operand -> m Operand
LLVM.ne
                  ComparisonOperator
LtOp -> Operand -> Operand -> IRBuilderT Llvm Operand
forall (m :: * -> *).
(MonadIRBuilder m, HasCallStack) =>
Operand -> Operand -> m Operand
LLVM.slt
                  ComparisonOperator
LeOp -> Operand -> Operand -> IRBuilderT Llvm Operand
forall (m :: * -> *).
(MonadIRBuilder m, HasCallStack) =>
Operand -> Operand -> m Operand
LLVM.sle
                  ComparisonOperator
GtOp -> Operand -> Operand -> IRBuilderT Llvm Operand
forall (m :: * -> *).
(MonadIRBuilder m, HasCallStack) =>
Operand -> Operand -> m Operand
LLVM.sgt
                  ComparisonOperator
GeOp -> Operand -> Operand -> IRBuilderT Llvm Operand
forall (m :: * -> *).
(MonadIRBuilder m, HasCallStack) =>
Operand -> Operand -> m Operand
LLVM.sge
             in (\Operand
a Operand
b -> Operand -> Operand -> IRBuilderT Llvm Operand
cOpF Operand
a Operand
b IRBuilderT Llvm Operand
-> (Operand -> IRBuilderT Llvm Operand) -> IRBuilderT Llvm Operand
forall a b.
IRBuilderT Llvm a -> (a -> IRBuilderT Llvm b) -> IRBuilderT Llvm b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Operand -> IRBuilderT Llvm Operand
boolToInt)
    Operand -> Operand -> IRBuilderT Llvm Operand
opF Operand
lhs' Operand
rhs'
  CompUnOp UnaryOperator
op AtomicExpression
x -> do
    Operand
x' <- AtomicExpression -> IRBuilderT Llvm Operand
genAtom AtomicExpression
x
    let opF :: Operand -> IRBuilderT Llvm Operand
opF = case UnaryOperator
op of
          UnaryOperator
UnMinusOp -> Operand -> Operand -> IRBuilderT Llvm Operand
forall (m :: * -> *).
(MonadIRBuilder m, HasCallStack) =>
Operand -> Operand -> m Operand
LLVM.mul (Integer -> Operand
LLVM.int64 (-Integer
1))
    Operand -> IRBuilderT Llvm Operand
opF Operand
x'

-- Vars & Funs

findAny :: Identifier' -> CodeGenM LLVM.Operand
findAny :: Identifier' -> IRBuilderT Llvm Operand
findAny Identifier'
ident = do
  Maybe Operand
maybeLocVar <- (Env -> Maybe Operand) -> IRBuilderT Llvm (Maybe Operand)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((Map Identifier' Operand -> Identifier' -> Maybe Operand
forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? Identifier'
ident) (Map Identifier' Operand -> Maybe Operand)
-> (Env -> Map Identifier' Operand) -> Env -> Maybe Operand
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> Map Identifier' Operand
locVars)
  case Maybe Operand
maybeLocVar of
    Just Operand
locVar -> Operand -> IRBuilderT Llvm Operand
forall a. a -> IRBuilderT Llvm a
forall (m :: * -> *) a. Monad m => a -> m a
return Operand
locVar
    Maybe Operand
Nothing -> do
      Maybe (Operand, Arity)
maybeFun <- (Env -> Maybe (Operand, Arity))
-> IRBuilderT Llvm (Maybe (Operand, Arity))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((Map Identifier' (Operand, Arity)
-> Identifier' -> Maybe (Operand, Arity)
forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? Identifier'
ident) (Map Identifier' (Operand, Arity) -> Maybe (Operand, Arity))
-> (Env -> Map Identifier' (Operand, Arity))
-> Env
-> Maybe (Operand, Arity)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> Map Identifier' (Operand, Arity)
funs)
      case Maybe (Operand, Arity)
maybeFun of
        Just (Operand
fun, Arity
arity) -> do
          Operand
funToPafF <- Identifier' -> IRBuilderT Llvm Operand
findFun (Identifier -> Identifier'
Txt Identifier
"miniml_fun_to_paf")
          Operand
fun' <- Operand -> Type -> IRBuilderT Llvm Operand
forall (m :: * -> *).
(MonadIRBuilder m, HasCallStack) =>
Operand -> Type -> m Operand
LLVM.ptrtoint Operand
fun Type
LLVM.i64
          Operand -> [Operand] -> IRBuilderT Llvm Operand
forall (m :: * -> *).
(HasCallStack, MonadIRBuilder m) =>
Operand -> [Operand] -> m Operand
LLVM.call Operand
funToPafF [Operand
fun', Integer -> Operand
LLVM.int64 (Arity -> Integer
forall a. Integral a => a -> Integer
toInteger Arity
arity)]
        Maybe (Operand, Arity)
Nothing -> Operand -> IRBuilderT Llvm Operand
load' (Operand -> IRBuilderT Llvm Operand)
-> IRBuilderT Llvm Operand -> IRBuilderT Llvm Operand
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Identifier' -> IRBuilderT Llvm Operand
forall (m :: * -> *). MonadState Env m => Identifier' -> m Operand
findGlobVar Identifier'
ident

findGlobVar :: (MonadState Env m) => Identifier' -> m LLVM.Operand
findGlobVar :: forall (m :: * -> *). MonadState Env m => Identifier' -> m Operand
findGlobVar Identifier'
ident = (Env -> Operand) -> m Operand
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((Map Identifier' Operand -> Identifier' -> Operand
forall k a. Ord k => Map k a -> k -> a
Map.! Identifier'
ident) (Map Identifier' Operand -> Operand)
-> (Env -> Map Identifier' Operand) -> Env -> Operand
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> Map Identifier' Operand
globVars)

findFun :: Identifier' -> CodeGenM LLVM.Operand
findFun :: Identifier' -> IRBuilderT Llvm Operand
findFun Identifier'
ident = (Env -> Operand) -> IRBuilderT Llvm Operand
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((Operand, Arity) -> Operand
forall a b. (a, b) -> a
fst ((Operand, Arity) -> Operand)
-> (Env -> (Operand, Arity)) -> Env -> Operand
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Identifier' (Operand, Arity) -> Identifier' -> (Operand, Arity)
forall k a. Ord k => Map k a -> k -> a
Map.! Identifier'
ident) (Map Identifier' (Operand, Arity) -> (Operand, Arity))
-> (Env -> Map Identifier' (Operand, Arity))
-> Env
-> (Operand, Arity)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> Map Identifier' (Operand, Arity)
funs)

regLocVar :: (MonadState Env m) => Identifier' -> LLVM.Operand -> m ()
regLocVar :: forall (m :: * -> *).
MonadState Env m =>
Identifier' -> Operand -> m ()
regLocVar Identifier'
ident Operand
var = (Env -> Env) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Env -> Env) -> m ()) -> (Env -> Env) -> m ()
forall a b. (a -> b) -> a -> b
$
  \Env
env -> Env
env {locVars :: Map Identifier' Operand
locVars = Identifier'
-> Operand -> Map Identifier' Operand -> Map Identifier' Operand
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Identifier'
ident Operand
var (Env -> Map Identifier' Operand
locVars Env
env)}

regGlobVar :: (MonadState Env m) => Identifier' -> LLVM.Operand -> m ()
regGlobVar :: forall (m :: * -> *).
MonadState Env m =>
Identifier' -> Operand -> m ()
regGlobVar Identifier'
ident Operand
gVar = (Env -> Env) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Env -> Env) -> m ()) -> (Env -> Env) -> m ()
forall a b. (a -> b) -> a -> b
$
  \Env
env -> Env
env {globVars :: Map Identifier' Operand
globVars = Identifier'
-> Operand -> Map Identifier' Operand -> Map Identifier' Operand
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Identifier'
ident Operand
gVar (Env -> Map Identifier' Operand
globVars Env
env)}

regFun :: (MonadState Env m) => Identifier' -> LLVM.Operand -> Arity -> m ()
regFun :: forall (m :: * -> *).
MonadState Env m =>
Identifier' -> Operand -> Arity -> m ()
regFun Identifier'
ident Operand
fun Arity
paramsCnt = (Env -> Env) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Env -> Env) -> m ()) -> (Env -> Env) -> m ()
forall a b. (a -> b) -> a -> b
$
  \Env
env -> Env
env {funs :: Map Identifier' (Operand, Arity)
funs = Identifier'
-> (Operand, Arity)
-> Map Identifier' (Operand, Arity)
-> Map Identifier' (Operand, Arity)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Identifier'
ident (Operand
fun, Arity
paramsCnt) (Env -> Map Identifier' (Operand, Arity)
funs Env
env)}

-- Allocation utils

allocate' :: CodeGenM LLVM.Operand
allocate' :: IRBuilderT Llvm Operand
allocate' = Type -> Maybe Operand -> Arity -> IRBuilderT Llvm Operand
forall (m :: * -> *).
(MonadIRBuilder m, HasCallStack) =>
Type -> Maybe Operand -> Arity -> m Operand
LLVM.alloca Type
LLVM.i64 Maybe Operand
forall a. Maybe a
Nothing Arity
0

load' :: LLVM.Operand -> CodeGenM LLVM.Operand
load' :: Operand -> IRBuilderT Llvm Operand
load' Operand
addr = Operand -> Alignment -> IRBuilderT Llvm Operand
forall (m :: * -> *).
(HasCallStack, MonadIRBuilder m) =>
Operand -> Alignment -> m Operand
LLVM.load Operand
addr Alignment
0

store' :: LLVM.Operand -> LLVM.Operand -> CodeGenM ()
store' :: Operand -> Operand -> IRBuilderT Llvm ()
store' Operand
addr = Operand -> Alignment -> Operand -> IRBuilderT Llvm ()
forall (m :: * -> *).
(MonadIRBuilder m, HasCallStack) =>
Operand -> Alignment -> Operand -> m ()
LLVM.store Operand
addr Alignment
0

-- Conversion utils

boolToInt :: LLVM.Operand -> CodeGenM LLVM.Operand
boolToInt :: Operand -> IRBuilderT Llvm Operand
boolToInt = (Operand -> Type -> IRBuilderT Llvm Operand)
-> Type -> Operand -> IRBuilderT Llvm Operand
forall a b c. (a -> b -> c) -> b -> a -> c
flip Operand -> Type -> IRBuilderT Llvm Operand
forall (m :: * -> *).
(MonadIRBuilder m, HasCallStack) =>
Operand -> Type -> m Operand
LLVM.zext Type
LLVM.i64

intToBool :: LLVM.Operand -> CodeGenM LLVM.Operand
intToBool :: Operand -> IRBuilderT Llvm Operand
intToBool = (Operand -> Type -> IRBuilderT Llvm Operand)
-> Type -> Operand -> IRBuilderT Llvm Operand
forall a b c. (a -> b -> c) -> b -> a -> c
flip Operand -> Type -> IRBuilderT Llvm Operand
forall (m :: * -> *).
(MonadIRBuilder m, HasCallStack) =>
Operand -> Type -> m Operand
LLVM.trunc Type
LLVM.i1