{-# LANGUAGE RecordWildCards #-}

{- | Emits JVM bytecode from the Core AST

The emitting process:
Every module is translated to a class file.
For each declaration, we turn it into a field if it is a value (i.e. a zero argument function, including IO actions),
or a method if it is a function.

*Translation of functions to methods:*

The emitter will eta expand declarations:
@ let id = \x -> x@
will be translated to:
@ public static Object id(Object x) { return x; }@

however it does not do any complex analysis on the code:
@ let add x =
if x == 0 then \y -> y else \y -> x + y
@
The higher order function here _can_ be avoided if we rearrange the code into:
@ let add = \x -> \y ->
if x == 0 then y else x + y
@
but this responsibility is left to the CoreToCore pass, so the emitter will still produce inefficient code:

@ public static Func add(int x) {
if (x == 0) {
    return (y) -> y;
} else {
    return (y) -> x + y;
}
}
@

What this means is that the emitted method's arity will always match the declared arity of the function
(i.e. how many directly nested lambdas there are)
-}
module Elara.JVM.Emit (emitIRModule) where

import Effectful
import Effectful.Error.Static (throwError)
import Effectful.State.Static.Local
import H2JVM as JVM
import H2JVM.Analyse.StackMap
import H2JVM.Builder
import H2JVM.Builder.Code
import H2JVM.ClassFile.AccessFlags (FieldAccessFlag (..))
import H2JVM.ClassFile.Method
import H2JVM.Instruction (IfCond (..))
import H2JVM.Internal.Raw.Types
import H2JVM.Name
import H2JVM.Type
import Witch

import Effectful.Error.Static qualified as Eff

import Elara.Data.Pretty (prettyToText)
import Elara.Data.Unique
import Elara.JVM.Emit.Operator (translateOperatorName)
import Elara.JVM.Emit.State
import Elara.JVM.Emit.Types (stringTypeName)
import Elara.JVM.Error
import Elara.JVM.IR as IR
import Elara.Logging

import Elara.Prim qualified as Prim

-- | Emit an IR Module to a list of ClassFiles
emitIRModule :: (StructuredDebug :> r, Eff.Error JVMLoweringError :> r) => IR.Module -> Eff r [ClassFile]
emitIRModule :: forall (r :: [Effect]).
(StructuredDebug :> r, Error JVMLoweringError :> r) =>
Module -> Eff r [ClassFile]
emitIRModule (IR.Module QualifiedClassName
moduleName [Class]
classes) = do
    [Class] -> (Class -> Eff r ClassFile) -> Eff r [ClassFile]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Class]
classes ((Class -> Eff r ClassFile) -> Eff r [ClassFile])
-> (Class -> Eff r ClassFile) -> Eff r [ClassFile]
forall a b. (a -> b) -> a -> b
$ ((ClassFile, ()) -> ClassFile)
-> Eff r (ClassFile, ()) -> Eff r ClassFile
forall a b. (a -> b) -> Eff r a -> Eff r b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ClassFile, ()) -> ClassFile
forall a b. (a, b) -> a
fst (Eff r (ClassFile, ()) -> Eff r ClassFile)
-> (Class -> Eff r (ClassFile, ())) -> Class -> Eff r ClassFile
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualifiedClassName
-> JVMVersion -> Eff (ClassBuilder : r) () -> Eff r (ClassFile, ())
forall (r :: [Effect]) a.
QualifiedClassName
-> JVMVersion -> Eff (ClassBuilder : r) a -> Eff r (ClassFile, a)
runClassBuilder QualifiedClassName
moduleName JVMVersion
java8 (Eff (ClassBuilder : r) () -> Eff r (ClassFile, ()))
-> (Class -> Eff (ClassBuilder : r) ())
-> Class
-> Eff r (ClassFile, ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> Eff (ClassBuilder : r) ()
forall (r :: [Effect]).
(StructuredDebug :> r, ClassBuilder :> r,
 Error JVMLoweringError :> r) =>
Class -> Eff r ()
emitIRClass

-- | Emit a single IR Class to a ClassFile
emitIRClass :: (StructuredDebug :> r, ClassBuilder :> r, Eff.Error JVMLoweringError :> r) => IR.Class -> Eff r ()
emitIRClass :: forall (r :: [Effect]).
(StructuredDebug :> r, ClassBuilder :> r,
 Error JVMLoweringError :> r) =>
Class -> Eff r ()
emitIRClass (IR.Class QualifiedClassName
className QualifiedClassName
super [Field]
fields [Method]
methods [Constructor]
constructors) = do
    QualifiedClassName -> Eff r ()
forall (r :: [Effect]).
(ClassBuilder :> r) =>
QualifiedClassName -> Eff r ()
setName QualifiedClassName
className
    QualifiedClassName -> Eff r ()
forall (r :: [Effect]).
(ClassBuilder :> r) =>
QualifiedClassName -> Eff r ()
setSuperClass QualifiedClassName
super
    ClassAccessFlag -> Eff r ()
forall (r :: [Effect]).
(ClassBuilder :> r) =>
ClassAccessFlag -> Eff r ()
addAccessFlag ClassAccessFlag
CPublic
    (Field -> Eff r ()) -> [Field] -> Eff r ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Field -> Eff r ()
forall (r :: [Effect]).
(StructuredDebug :> r, ClassBuilder :> r) =>
Field -> Eff r ()
emitIRField [Field]
fields
    (Method -> Eff r ()) -> [Method] -> Eff r ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (QualifiedClassName -> Method -> Eff r ()
forall (r :: [Effect]).
(StructuredDebug :> r, ClassBuilder :> r, HasCallStack,
 Error JVMLoweringError :> r) =>
QualifiedClassName -> Method -> Eff r ()
emitIRMethod QualifiedClassName
className) [Method]
methods
    (Constructor -> Eff r ()) -> [Constructor] -> Eff r ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (QualifiedClassName -> Constructor -> Eff r ()
forall (r :: [Effect]).
(StructuredDebug :> r, ClassBuilder :> r,
 Error JVMLoweringError :> r) =>
QualifiedClassName -> Constructor -> Eff r ()
emitConstructor QualifiedClassName
className) [Constructor]
constructors
    Bool -> Eff r () -> Eff r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (QualifiedClassName -> [Method] -> Bool
shouldAddMainMethod QualifiedClassName
className [Method]
methods) (Eff r () -> Eff r ()) -> Eff r () -> Eff r ()
forall a b. (a -> b) -> a -> b
$
        QualifiedClassName -> Eff r ()
forall (r :: [Effect]).
(StructuredDebug :> r, ClassBuilder :> r,
 Error JVMLoweringError :> r) =>
QualifiedClassName -> Eff r ()
emitJVMMainMethod QualifiedClassName
className
  where
    shouldAddMainMethod :: QualifiedClassName -> [IR.Method] -> Bool
    shouldAddMainMethod :: QualifiedClassName -> [Method] -> Bool
shouldAddMainMethod (QualifiedClassName PackageName
_ (ClassName Text
"Main")) =
        (Method -> Bool) -> [Method] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Method -> Bool
isElaraMain
    shouldAddMainMethod QualifiedClassName
_ = Bool -> [Method] -> Bool
forall a b. a -> b -> a
const Bool
False

    isElaraMain :: IR.Method -> Bool
    isElaraMain :: Method -> Bool
isElaraMain (IR.Method Text
name (MethodDescriptor [FieldType]
_ (TypeReturn (ObjectFieldType QualifiedClassName
ioCls))) [(Unique Text, FieldType)]
_ [Block]
_ Bool
True) =
        Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"main" Bool -> Bool -> Bool
&& QualifiedClassName
ioCls QualifiedClassName -> QualifiedClassName -> Bool
forall a. Eq a => a -> a -> Bool
== QualifiedClassName
"Elara.IO"
    isElaraMain Method
_ = Bool
False

-- | Emit a field to the current class
emitIRField :: (StructuredDebug :> r, ClassBuilder :> r) => IR.Field -> Eff r ()
emitIRField :: forall (r :: [Effect]).
(StructuredDebug :> r, ClassBuilder :> r) =>
Field -> Eff r ()
emitIRField (IR.Field Text
fieldName FieldType
fieldType) = do
    let fieldInfo :: ClassFileField
fieldInfo =
            [FieldAccessFlag]
-> Text -> FieldType -> [FieldAttribute] -> ClassFileField
ClassFileField
                [FieldAccessFlag
FPublic]
                Text
fieldName
                FieldType
fieldType
                []
    ClassFileField -> Eff r ()
forall (r :: [Effect]).
(ClassBuilder :> r) =>
ClassFileField -> Eff r ()
addField ClassFileField
fieldInfo

-- | Emit a method to the current class
emitIRMethod :: (StructuredDebug :> r, ClassBuilder :> r, HasCallStack, Eff.Error JVMLoweringError :> r) => QualifiedClassName -> IR.Method -> Eff r ()
emitIRMethod :: forall (r :: [Effect]).
(StructuredDebug :> r, ClassBuilder :> r, HasCallStack,
 Error JVMLoweringError :> r) =>
QualifiedClassName -> Method -> Eff r ()
emitIRMethod QualifiedClassName
thisClassName (IR.Method Text
methodName MethodDescriptor
methodDescriptor [(Unique Text, FieldType)]
methodArgs [Block]
methodCode Bool
isStatic) = do
    let createState :: [Unique Text] -> QualifiedClassName -> MethodCreationState
createState = if Bool
isStatic then [Unique Text] -> QualifiedClassName -> MethodCreationState
createMethodCreationState else [Unique Text] -> QualifiedClassName -> MethodCreationState
createInstanceMethodCreationState
        accessFlags :: [MethodAccessFlag]
accessFlags = if Bool
isStatic then [MethodAccessFlag
MPublic, MethodAccessFlag
MStatic] else [MethodAccessFlag
MPublic]
    (methodCreationState, codeAttributes, instructions) <-
        Eff (CodeBuilder : r) MethodCreationState
-> Eff
     r (MethodCreationState, [CodeAttribute], NonEmpty Instruction)
forall (r :: [Effect]) a.
HasCallStack =>
Eff (CodeBuilder : r) a
-> Eff r (a, [CodeAttribute], NonEmpty Instruction)
runCodeBuilder (Eff (CodeBuilder : r) MethodCreationState
 -> Eff
      r (MethodCreationState, [CodeAttribute], NonEmpty Instruction))
-> Eff (CodeBuilder : r) MethodCreationState
-> Eff
     r (MethodCreationState, [CodeAttribute], NonEmpty Instruction)
forall a b. (a -> b) -> a -> b
$
            MethodCreationState
-> Eff (State MethodCreationState : CodeBuilder : r) [()]
-> Eff (CodeBuilder : r) MethodCreationState
forall s (es :: [Effect]) a.
HasCallStack =>
s -> Eff (State s : es) a -> Eff es s
execState
                ([Unique Text] -> QualifiedClassName -> MethodCreationState
createState ((Unique Text, FieldType) -> Unique Text
forall a b. (a, b) -> a
fst ((Unique Text, FieldType) -> Unique Text)
-> [(Unique Text, FieldType)] -> [Unique Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Unique Text, FieldType)]
methodArgs) QualifiedClassName
thisClassName)
                ((Block -> Eff (State MethodCreationState : CodeBuilder : r) ())
-> [Block]
-> Eff (State MethodCreationState : CodeBuilder : r) [()]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Block -> Eff (State MethodCreationState : CodeBuilder : r) ()
forall (r :: [Effect]). EmitCode r => Block -> Eff r ()
emitIRBlock [Block]
methodCode)
    method <-
        buildClassFileMethod
            (translateOperatorName methodName)
            accessFlags
            methodDescriptor
            thisClassName
            codeAttributes
            instructions
    addMethod method

-- | Create method creation state for instance methods
createInstanceMethodCreationState ::
    -- | Argument names
    [Unique Text] ->
    -- | Name of the class containing the method
    QualifiedClassName ->
    MethodCreationState
createInstanceMethodCreationState :: [Unique Text] -> QualifiedClassName -> MethodCreationState
createInstanceMethodCreationState [Unique Text]
args QualifiedClassName
thisName =
    Map LVKey U2
-> QualifiedClassName
-> Map (Unique Text) Label
-> MethodCreationState
MethodCreationState
        ([Item (Map LVKey U2)] -> Map LVKey U2
forall l. IsList l => [Item l] -> l
fromList ([Item (Map LVKey U2)] -> Map LVKey U2)
-> [Item (Map LVKey U2)] -> Map LVKey U2
forall a b. (a -> b) -> a -> b
$ [LVKey] -> [U2] -> [(LVKey, U2)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Unique Text -> LVKey
KnownName (Unique Text -> LVKey) -> [Unique Text] -> [LVKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Unique Text]
args) [U2
1 ..])
        QualifiedClassName
thisName
        Map (Unique Text) Label
forall a. Monoid a => a
mempty

-- | Emit a constructor to the current class
emitConstructor :: (StructuredDebug :> r, ClassBuilder :> r, Eff.Error JVMLoweringError :> r) => QualifiedClassName -> IR.Constructor -> Eff r ()
emitConstructor :: forall (r :: [Effect]).
(StructuredDebug :> r, ClassBuilder :> r,
 Error JVMLoweringError :> r) =>
QualifiedClassName -> Constructor -> Eff r ()
emitConstructor QualifiedClassName
className (IR.Constructor MethodDescriptor
constructorDesc [(Unique Text, FieldType)]
constructorArgs [Block]
constructorCode) = do
    (emitState, codeAttributes, instructions) <-
        Eff (CodeBuilder : r) MethodCreationState
-> Eff
     r (MethodCreationState, [CodeAttribute], NonEmpty Instruction)
forall (r :: [Effect]) a.
HasCallStack =>
Eff (CodeBuilder : r) a
-> Eff r (a, [CodeAttribute], NonEmpty Instruction)
runCodeBuilder (Eff (CodeBuilder : r) MethodCreationState
 -> Eff
      r (MethodCreationState, [CodeAttribute], NonEmpty Instruction))
-> Eff (CodeBuilder : r) MethodCreationState
-> Eff
     r (MethodCreationState, [CodeAttribute], NonEmpty Instruction)
forall a b. (a -> b) -> a -> b
$
            MethodCreationState
-> Eff (State MethodCreationState : CodeBuilder : r) [()]
-> Eff (CodeBuilder : r) MethodCreationState
forall s (es :: [Effect]) a.
HasCallStack =>
s -> Eff (State s : es) a -> Eff es s
execState
                ([Unique Text] -> QualifiedClassName -> MethodCreationState
createInstanceMethodCreationState ((Unique Text, FieldType) -> Unique Text
forall a b. (a, b) -> a
fst ((Unique Text, FieldType) -> Unique Text)
-> [(Unique Text, FieldType)] -> [Unique Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Unique Text, FieldType)]
constructorArgs) QualifiedClassName
className)
                ((Block -> Eff (State MethodCreationState : CodeBuilder : r) ())
-> [Block]
-> Eff (State MethodCreationState : CodeBuilder : r) [()]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Block -> Eff (State MethodCreationState : CodeBuilder : r) ()
forall (r :: [Effect]). EmitCode r => Block -> Eff r ()
emitIRBlock [Block]
constructorCode)
    method <- buildClassFileMethod "<init>" [MPublic] constructorDesc className codeAttributes instructions
    addMethod method

-- | Build a ClassFileMethod with the standard Code attribute
buildClassFileMethod ::
    Eff.Error JVMLoweringError :> w =>
    -- | Method name
    Text ->
    -- | Access flags
    [MethodAccessFlag] ->
    -- | Method descriptor
    MethodDescriptor ->
    -- | Class name (for stack map calculation)
    QualifiedClassName ->
    -- | Additional code attributes
    [CodeAttribute] ->
    -- | Body of the method
    NonEmpty JVM.Instruction ->
    Eff w ClassFileMethod
buildClassFileMethod :: forall (w :: [Effect]).
(Error JVMLoweringError :> w) =>
Text
-> [MethodAccessFlag]
-> MethodDescriptor
-> QualifiedClassName
-> [CodeAttribute]
-> NonEmpty Instruction
-> Eff w ClassFileMethod
buildClassFileMethod Text
name [MethodAccessFlag]
accessFlags MethodDescriptor
desc QualifiedClassName
className [CodeAttribute]
codeAttrs NonEmpty Instruction
instructions = do
    (stackMap, maxStack, maxLocals) <- (StackMapError -> Eff w ([StackMapFrame], Int, Int))
-> (([StackMapFrame], Int, Int)
    -> Eff w ([StackMapFrame], Int, Int))
-> Either StackMapError ([StackMapFrame], Int, Int)
-> Eff w ([StackMapFrame], Int, Int)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (JVMLoweringError -> Eff w ([StackMapFrame], Int, Int)
forall e (es :: [Effect]) a.
(HasCallStack, Error e :> es, Show e) =>
e -> Eff es a
throwError (JVMLoweringError -> Eff w ([StackMapFrame], Int, Int))
-> (StackMapError -> JVMLoweringError)
-> StackMapError
-> Eff w ([StackMapFrame], Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackMapError -> JVMLoweringError
H2JVMError) ([StackMapFrame], Int, Int) -> Eff w ([StackMapFrame], Int, Int)
forall a. a -> Eff w a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HasCallStack =>
QualifiedClassName
-> [MethodAccessFlag]
-> MethodDescriptor
-> NonEmpty Instruction
-> Either StackMapError ([StackMapFrame], Int, Int)
QualifiedClassName
-> [MethodAccessFlag]
-> MethodDescriptor
-> NonEmpty Instruction
-> Either StackMapError ([StackMapFrame], Int, Int)
calculateStackMapFrames QualifiedClassName
className [MethodAccessFlag]
accessFlags MethodDescriptor
desc NonEmpty Instruction
instructions)
    maxStack' <- convertMaxStackOrLocals maxStack MethodTooManyStack
    maxLocals' <- convertMaxStackOrLocals maxLocals MethodTooManyLocals
    pure
        ClassFileMethod
            { methodAccessFlags = accessFlags
            , methodName = name
            , methodDescriptor = desc
            , methodAttributes =
                fromList
                    [ Code $
                        CodeAttributeData
                            { maxStack = maxStack'
                            , maxLocals = maxLocals'
                            , code = instructions
                            , exceptionTable = []
                            , codeAttributes = StackMapTable stackMap : codeAttrs
                            }
                    ]
            }

-- | Effects needed to emit JVM code to a method
type EmitCode r = (StructuredDebug :> r, CodeBuilder :> r, State MethodCreationState :> r, HasCallStack)

-- | Emit a block of IR instructions
emitIRBlock :: EmitCode r => IR.Block -> Eff r ()
emitIRBlock :: forall (r :: [Effect]). EmitCode r => Block -> Eff r ()
emitIRBlock (IR.Block Unique Text
label [Instruction]
instrs) = do
    label' <- Unique Text -> Eff r Label
forall (r :: [Effect]).
(State MethodCreationState :> r, CodeBuilder :> r) =>
Unique Text -> Eff r Label
getLabel Unique Text
label
    emit $ JVM.Label label'
    mapM_ emitIRInstruction instrs

-- | Emit a single IR instruction to JVM instructions
emitIRInstruction :: EmitCode r => IR.Instruction -> Eff r ()
emitIRInstruction :: forall (r :: [Effect]). EmitCode r => Instruction -> Eff r ()
emitIRInstruction Instruction
instr = case Instruction
instr of
    IR.Assign Unique Text
var FieldType
t Expr
expr -> do
        Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
expr
        case FieldType
t of
            JVM.PrimitiveFieldType PrimitiveType
_ -> Eff r ()
forall (f :: * -> *). Applicative f => f ()
pass -- no need to checkcast for primitives
            FieldType
_ -> Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Instruction
forall label. ClassInfoType -> Instruction' label
CheckCast (FieldType -> ClassInfoType
fieldTypeToClassInfoType FieldType
t) -- ensure correct type, might not always be necessary
        allocation <- Unique Text -> Eff r U2
forall (r :: [Effect]).
(State MethodCreationState :> r) =>
Unique Text -> Eff r U2
findLocalVariable Unique Text
var
        case t of
            JVM.PrimitiveFieldType PrimitiveType
JInt -> Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ U2 -> Instruction
forall label. U2 -> Instruction' label
IStore U2
allocation
            JVM.PrimitiveFieldType PrimitiveType
other -> Text -> Eff r ()
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Eff r ()) -> Text -> Eff r ()
forall a b. (a -> b) -> a -> b
$ Text
"emitIRInstruction: Unhandled primitive type in Assign: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PrimitiveType -> Text
forall a. Pretty a => a -> Text
prettyToText PrimitiveType
other
            FieldType
_ -> Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ U2 -> Instruction
forall label. U2 -> Instruction' label
AStore U2
allocation
    IR.Return Maybe Expr
Nothing -> Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit Instruction
forall label. Instruction' label
JVM.Return
    IR.Return (Just Expr
e) -> do
        Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
e
        Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit Instruction
forall label. Instruction' label
JVM.AReturn
    IR.IReturn Expr
e -> do
        Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
e
        Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit Instruction
forall label. Instruction' label
JVM.IReturn
    IR.Jump Unique Text
label -> do
        label' <- Unique Text -> Eff r Label
forall (r :: [Effect]).
(State MethodCreationState :> r, CodeBuilder :> r) =>
Unique Text -> Eff r Label
getLabel Unique Text
label
        emit $ Goto label'
    IR.JumpIf Expr
cond Unique Text
trueLabel Unique Text
falseLabel -> do
        exprType <- Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
cond
        case exprType of
            Just (PrimitiveClassInfoType PrimitiveType
JBoolean) -> do
                trueLabel' <- Unique Text -> Eff r Label
forall (r :: [Effect]).
(State MethodCreationState :> r, CodeBuilder :> r) =>
Unique Text -> Eff r Label
getLabel Unique Text
trueLabel
                falseLabel' <- getLabel falseLabel
                emit $ If $ IfEq falseLabel'
                emit $ Goto trueLabel'
            Just (ClassInfoType QualifiedClassName
"Elara.Prim.Bool") -> do
                trueLabel' <- Unique Text -> Eff r Label
forall (r :: [Effect]).
(State MethodCreationState :> r, CodeBuilder :> r) =>
Unique Text -> Eff r Label
getLabel Unique Text
trueLabel
                falseLabel' <- getLabel falseLabel
                emit $ Instanceof (ClassInfoType "Elara.Prim.True")
                emit $ If $ IfEq falseLabel'
                emit $ Goto trueLabel'
            Maybe ClassInfoType
other -> Text -> Eff r ()
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Eff r ()) -> Text -> Eff r ()
forall a b. (a -> b) -> a -> b
$ Text
"emitIRInstruction: JumpIf condition has unsupported type: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe ClassInfoType -> Text
forall a. Pretty a => a -> Text
prettyToText Maybe ClassInfoType
other
    IR.JumpIfPrimitiveBool Expr
cond Unique Text
trueLabel Unique Text
falseLabel -> do
        Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
cond
        trueLabel' <- Unique Text -> Eff r Label
forall (r :: [Effect]).
(State MethodCreationState :> r, CodeBuilder :> r) =>
Unique Text -> Eff r Label
getLabel Unique Text
trueLabel
        falseLabel' <- getLabel falseLabel
        emit $ If $ IfEq falseLabel' -- since 0 = false
        emit $ Goto trueLabel'
    IR.ExprStmt Expr
expr -> Eff r (Maybe ClassInfoType) -> Eff r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
expr)
    IR.Super QualifiedClassName
superName [Expr]
args -> do
        Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ U2 -> Instruction
forall label. U2 -> Instruction' label
JVM.ALoad U2
0
        [Expr] -> (Expr -> Eff r (Maybe ClassInfoType)) -> Eff r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Expr]
args Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr
        let argTypes :: [FieldType]
argTypes = Int -> FieldType -> [FieldType]
forall a. Int -> a -> [a]
replicate ([Expr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expr]
args) (QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
"java/lang/Object") -- TODO: get proper types
        Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$
            ClassInfoType -> Text -> MethodDescriptor -> Instruction
forall label.
ClassInfoType -> Text -> MethodDescriptor -> Instruction' label
JVM.InvokeSpecial
                (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
superName)
                Text
"<init>"
                ([FieldType] -> ReturnDescriptor -> MethodDescriptor
MethodDescriptor [FieldType]
argTypes ReturnDescriptor
VoidReturn)
    IR.SetField QualifiedClassName
fieldClass Text
field FieldType
fieldType Expr
val -> do
        Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ U2 -> Instruction
forall label. U2 -> Instruction' label
JVM.ALoad U2
0 -- load 'this'
        Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
val
        Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Text -> FieldType -> Instruction
forall label.
ClassInfoType -> Text -> FieldType -> Instruction' label
JVM.PutField (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
fieldClass) Text
field FieldType
fieldType

{- | Emit an expression onto the stack
Returns the type that will be on top of the stack after emitting the expression, if known
-}
emitExpr :: EmitCode r => IR.Expr -> Eff r (Maybe ClassInfoType)
emitExpr :: forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
expr = case Expr
expr of
    IR.LitInt Integer
n -> do
        Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ LDCEntry -> Instruction
forall label. LDCEntry -> Instruction' label
LDC (JVMInt -> LDCEntry
LDCInt (JVMInt -> LDCEntry) -> JVMInt -> LDCEntry
forall a b. (a -> b) -> a -> b
$ Integer -> JVMInt
forall a. Num a => Integer -> a
fromInteger Integer
n) -- TODO: fromInteger bad
        Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Text -> MethodDescriptor -> Instruction
forall label.
ClassInfoType -> Text -> MethodDescriptor -> Instruction' label
JVM.InvokeStatic (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"java.lang.Integer") Text
"valueOf" ([FieldType] -> ReturnDescriptor -> MethodDescriptor
MethodDescriptor [PrimitiveType -> FieldType
PrimitiveFieldType PrimitiveType
JVM.JInt] (FieldType -> ReturnDescriptor
TypeReturn (FieldType -> ReturnDescriptor) -> FieldType -> ReturnDescriptor
forall a b. (a -> b) -> a -> b
$ QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
"java.lang.Integer"))
        Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ClassInfoType -> Eff r (Maybe ClassInfoType))
-> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Maybe ClassInfoType
forall a. a -> Maybe a
Just (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"java.lang.Integer")
    IR.PrimitiveLitInt Integer
n -> do
        Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ LDCEntry -> Instruction
forall label. LDCEntry -> Instruction' label
JVM.LDC (JVMInt -> LDCEntry
LDCInt (JVMInt -> LDCEntry) -> JVMInt -> LDCEntry
forall a b. (a -> b) -> a -> b
$ Integer -> JVMInt
forall a. Num a => Integer -> a
fromInteger Integer
n) -- TODO: fromInteger bad
        Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ClassInfoType -> Eff r (Maybe ClassInfoType))
-> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Maybe ClassInfoType
forall a. a -> Maybe a
Just (PrimitiveType -> ClassInfoType
PrimitiveClassInfoType PrimitiveType
JVM.JInt)
    IR.LitString Text
s -> do
        Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Instruction
forall label. ClassInfoType -> Instruction' label
JVM.New (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
stringTypeName)
        Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit Instruction
forall label. Instruction' label
JVM.Dup
        Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ LDCEntry -> Instruction
forall label. LDCEntry -> Instruction' label
LDC (Text -> LDCEntry
LDCString Text
s)
        Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Text -> MethodDescriptor -> Instruction
forall label.
ClassInfoType -> Text -> MethodDescriptor -> Instruction' label
JVM.InvokeSpecial (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
stringTypeName) Text
"<init>" ([FieldType] -> ReturnDescriptor -> MethodDescriptor
MethodDescriptor [QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
"java.lang.String"] ReturnDescriptor
VoidReturn)
        Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ClassInfoType -> Eff r (Maybe ClassInfoType))
-> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Maybe ClassInfoType
forall a. a -> Maybe a
Just (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
stringTypeName)
    IR.LitChar Char
c -> do
        Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ LDCEntry -> Instruction
forall label. LDCEntry -> Instruction' label
LDC (JVMInt -> LDCEntry
LDCInt (JVMInt -> LDCEntry) -> JVMInt -> LDCEntry
forall a b. (a -> b) -> a -> b
$ Int -> JVMInt
forall target source.
(HasCallStack, TryFrom source target, Show source, Typeable source,
 Typeable target) =>
source -> target
unsafeInto (Int -> JVMInt) -> Int -> JVMInt
forall a b. (a -> b) -> a -> b
$ Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c)
        Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Text -> MethodDescriptor -> Instruction
forall label.
ClassInfoType -> Text -> MethodDescriptor -> Instruction' label
JVM.InvokeStatic (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"java.lang.Character") Text
"valueOf" ([FieldType] -> ReturnDescriptor -> MethodDescriptor
MethodDescriptor [PrimitiveType -> FieldType
PrimitiveFieldType PrimitiveType
JVM.JChar] (FieldType -> ReturnDescriptor
TypeReturn (FieldType -> ReturnDescriptor) -> FieldType -> ReturnDescriptor
forall a b. (a -> b) -> a -> b
$ QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
"java.lang.Character"))
        Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ClassInfoType -> Eff r (Maybe ClassInfoType))
-> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Maybe ClassInfoType
forall a. a -> Maybe a
Just (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"java.lang.Character")
    IR.LitBool Bool
b -> Bool -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Bool -> Eff r (Maybe ClassInfoType)
emitElaraBool Bool
b
    IR.PrimitiveLitBool Bool
True -> Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit Instruction
forall label. Instruction' label
JVM.IConst1 Eff r ()
-> Eff r (Maybe ClassInfoType) -> Eff r (Maybe ClassInfoType)
forall a b. Eff r a -> Eff r b -> Eff r b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClassInfoType -> Maybe ClassInfoType
forall a. a -> Maybe a
Just (PrimitiveType -> ClassInfoType
PrimitiveClassInfoType PrimitiveType
JVM.JBoolean))
    IR.PrimitiveLitBool Bool
False -> Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit Instruction
forall label. Instruction' label
JVM.IConst0 Eff r ()
-> Eff r (Maybe ClassInfoType) -> Eff r (Maybe ClassInfoType)
forall a b. Eff r a -> Eff r b -> Eff r b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClassInfoType -> Maybe ClassInfoType
forall a. a -> Maybe a
Just (PrimitiveType -> ClassInfoType
PrimitiveClassInfoType PrimitiveType
JVM.JBoolean))
    Expr
IR.LitUnit -> do
        Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Text -> FieldType -> Instruction
forall label.
ClassInfoType -> Text -> FieldType -> Instruction' label
JVM.GetStatic (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"Elara.Prim.Unit") Text
"unit" (QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
"Elara.Prim.Unit")
        Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ClassInfoType -> Eff r (Maybe ClassInfoType))
-> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Maybe ClassInfoType
forall a. a -> Maybe a
Just (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"Elara.Prim.Unit")
    IR.InstanceOf Expr
e FieldType
t -> do
        Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
e
        Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Instruction
forall label. ClassInfoType -> Instruction' label
Instanceof (FieldType -> ClassInfoType
fieldTypeToClassInfoType FieldType
t)
        Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ClassInfoType -> Eff r (Maybe ClassInfoType))
-> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Maybe ClassInfoType
forall a. a -> Maybe a
Just (PrimitiveType -> ClassInfoType
PrimitiveClassInfoType PrimitiveType
JVM.JBoolean)
    IR.FieldRef QualifiedClassName
className Text
fieldName FieldType
fieldType -> do
        Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Text -> FieldType -> Instruction
forall label.
ClassInfoType -> Text -> FieldType -> Instruction' label
JVM.GetStatic (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
className) Text
fieldName FieldType
fieldType
        Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ClassInfoType -> Eff r (Maybe ClassInfoType))
-> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Maybe ClassInfoType
forall a. a -> Maybe a
Just (FieldType -> ClassInfoType
fieldTypeToClassInfoType FieldType
fieldType)
    IR.LocalVar Unique Text
u FieldType
t -> do
        allocation <- Unique Text -> Eff r U2
forall (r :: [Effect]).
(State MethodCreationState :> r) =>
Unique Text -> Eff r U2
findLocalVariable Unique Text
u
        case t of
            JVM.PrimitiveFieldType PrimitiveType
JInt -> Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (U2 -> Instruction
forall label. U2 -> Instruction' label
ILoad U2
allocation)
            JVM.PrimitiveFieldType PrimitiveType
other -> Text -> Eff r ()
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Eff r ()) -> Text -> Eff r ()
forall a b. (a -> b) -> a -> b
$ Text
"emitExpr: Unhandled primitive type in LocalVar: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PrimitiveType -> Text
forall a. Pretty a => a -> Text
prettyToText PrimitiveType
other
            FieldType
_ -> Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (U2 -> Instruction
forall label. U2 -> Instruction' label
ALoad U2
allocation)
        pure $ Just (fieldTypeToClassInfoType t)
    IR.This FieldType
_ -> do
        Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ U2 -> Instruction
forall label. U2 -> Instruction' label
ALoad U2
0
        Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ClassInfoType
forall a. Maybe a
Nothing
    IR.GetField Expr
obj ClassInfoType
fieldClass Text
fieldName FieldType
fieldType -> do
        Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
obj
        Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Instruction
forall label. ClassInfoType -> Instruction' label
JVM.CheckCast ClassInfoType
fieldClass
        Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Text -> FieldType -> Instruction
forall label.
ClassInfoType -> Text -> FieldType -> Instruction' label
JVM.GetField ClassInfoType
fieldClass Text
fieldName FieldType
fieldType
        Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ClassInfoType -> Eff r (Maybe ClassInfoType))
-> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Maybe ClassInfoType
forall a. a -> Maybe a
Just (FieldType -> ClassInfoType
fieldTypeToClassInfoType FieldType
fieldType)
    IR.Call CallType
f [Expr]
args -> do
        case CallType
f of
            IR.InvokeStatic QualifiedClassName
cls Text
name MethodDescriptor
desc -> do
                [Expr] -> (Expr -> Eff r (Maybe ClassInfoType)) -> Eff r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Expr]
args Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr
                Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Text -> MethodDescriptor -> Instruction
forall label.
ClassInfoType -> Text -> MethodDescriptor -> Instruction' label
JVM.InvokeStatic (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
cls) (Text -> Text
translateOperatorName Text
name) MethodDescriptor
desc
                Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ClassInfoType -> Eff r (Maybe ClassInfoType))
-> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a b. (a -> b) -> a -> b
$ case MethodDescriptor
desc of
                    MethodDescriptor [FieldType]
_ (TypeReturn FieldType
retType) -> ClassInfoType -> Maybe ClassInfoType
forall a. a -> Maybe a
Just (FieldType -> ClassInfoType
fieldTypeToClassInfoType FieldType
retType)
                    MethodDescriptor
_ -> Maybe ClassInfoType
forall a. Maybe a
Nothing
            IR.InvokeInterface Expr
target QualifiedClassName
targetType Text
name (MethodDescriptor [FieldType]
argTys ReturnDescriptor
ret) -> do
                Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
target
                [Expr] -> (Expr -> Eff r (Maybe ClassInfoType)) -> Eff r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Expr]
args Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr
                let obj :: FieldType
obj = QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
"java.lang.Object"
                    argTypes :: [FieldType]
argTypes = Int -> FieldType -> [FieldType]
forall a. Int -> a -> [a]
replicate ([FieldType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FieldType]
argTys) FieldType
obj
                    retType :: FieldType
retType = FieldType
obj
                    erasedDesc :: MethodDescriptor
erasedDesc = [FieldType] -> ReturnDescriptor -> MethodDescriptor
MethodDescriptor [FieldType]
argTypes (FieldType -> ReturnDescriptor
TypeReturn FieldType
retType)
                Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Text -> MethodDescriptor -> Instruction
forall label.
ClassInfoType -> Text -> MethodDescriptor -> Instruction' label
JVM.InvokeInterface (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
targetType) Text
name MethodDescriptor
erasedDesc

                case ReturnDescriptor
ret of
                    TypeReturn ft :: FieldType
ft@(ObjectFieldType QualifiedClassName
cls)
                        | QualifiedClassName
cls QualifiedClassName -> QualifiedClassName -> Bool
forall a. Eq a => a -> a -> Bool
/= QualifiedClassName
"java.lang.Object" -> do
                            Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Instruction
forall label. ClassInfoType -> Instruction' label
CheckCast (FieldType -> ClassInfoType
fieldTypeToClassInfoType FieldType
ft)
                            Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ClassInfoType -> Eff r (Maybe ClassInfoType))
-> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Maybe ClassInfoType
forall a. a -> Maybe a
Just (FieldType -> ClassInfoType
fieldTypeToClassInfoType FieldType
ft)
                    ReturnDescriptor
_ -> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ClassInfoType
forall a. Maybe a
Nothing
            IR.InvokeVirtual Expr
target QualifiedClassName
targetType Text
name desc :: MethodDescriptor
desc@(MethodDescriptor [FieldType]
_ ReturnDescriptor
ret) -> do
                Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
target
                [Expr] -> (Expr -> Eff r (Maybe ClassInfoType)) -> Eff r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Expr]
args Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr
                Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Text -> MethodDescriptor -> Instruction
forall label.
ClassInfoType -> Text -> MethodDescriptor -> Instruction' label
JVM.InvokeVirtual (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
targetType) Text
name MethodDescriptor
desc

                case ReturnDescriptor
ret of
                    TypeReturn ft :: FieldType
ft@(ObjectFieldType QualifiedClassName
cls)
                        | QualifiedClassName
cls QualifiedClassName -> QualifiedClassName -> Bool
forall a. Eq a => a -> a -> Bool
/= QualifiedClassName
"java.lang.Object" -> do
                            Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Instruction
forall label. ClassInfoType -> Instruction' label
CheckCast (FieldType -> ClassInfoType
fieldTypeToClassInfoType FieldType
ft)
                            Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ClassInfoType -> Eff r (Maybe ClassInfoType))
-> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Maybe ClassInfoType
forall a. a -> Maybe a
Just (FieldType -> ClassInfoType
fieldTypeToClassInfoType FieldType
ft)
                    ReturnDescriptor
_ -> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ClassInfoType
forall a. Maybe a
Nothing
    IR.BinaryOp BinOp
op Expr
lhs Expr
rhs -> do
        Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
lhs
        Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
rhs
        case BinOp
op of
            BinOp
IR.Equals -> do
                Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$
                    ClassInfoType -> Text -> MethodDescriptor -> Instruction
forall label.
ClassInfoType -> Text -> MethodDescriptor -> Instruction' label
JVM.InvokeStatic
                        (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"java.util.Objects")
                        Text
"equals"
                        ( [FieldType] -> ReturnDescriptor -> MethodDescriptor
MethodDescriptor
                            [QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
"java.lang.Object", QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
"java.lang.Object"]
                            (FieldType -> ReturnDescriptor
TypeReturn (FieldType -> ReturnDescriptor) -> FieldType -> ReturnDescriptor
forall a b. (a -> b) -> a -> b
$ PrimitiveType -> FieldType
PrimitiveFieldType PrimitiveType
JVM.JBoolean)
                        )
                Eff r (Maybe ClassInfoType)
forall (r :: [Effect]). EmitCode r => Eff r (Maybe ClassInfoType)
primitiveBooleanToElaraBoolean
            BinOp
IR.Subtract -> Text -> Expr -> Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Text -> Expr -> Expr -> Eff r (Maybe ClassInfoType)
emitBinaryIntOp Text
"minus" Expr
lhs Expr
rhs
            BinOp
IR.Add -> Text -> Expr -> Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Text -> Expr -> Expr -> Eff r (Maybe ClassInfoType)
emitBinaryIntOp Text
"add" Expr
lhs Expr
rhs
            BinOp
IR.GreaterThan -> do
                trueLabel <- Eff r Label
forall {k} (es :: [Effect]).
(HasCallStack, CodeBuilder :> es) =>
Eff es Label
newLabel
                endLabel <- newLabel
                emit $ JVM.IfICmp (IfGt trueLabel)
                emit JVM.IConst0
                emit $ Goto endLabel
                emit $ JVM.Label trueLabel
                emit JVM.IConst1
                emit $ JVM.Label endLabel
                primitiveBooleanToElaraBoolean
            BinOp
_ -> Text -> Eff r (Maybe ClassInfoType)
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Eff r (Maybe ClassInfoType))
-> Text -> Eff r (Maybe ClassInfoType)
forall a b. (a -> b) -> a -> b
$ Text
"emitExpr: Unhandled binary operator: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BinOp -> Text
forall a. Pretty a => a -> Text
prettyToText BinOp
op
    IR.MakeClosure{[(Expr, FieldType)]
Text
QualifiedClassName
MethodDescriptor
closureTargetClass :: QualifiedClassName
closureTargetMethod :: Text
closureTarget :: MethodDescriptor
closureInterface :: QualifiedClassName
capturedValues :: [(Expr, FieldType)]
capturedValues :: Expr -> [(Expr, FieldType)]
closureInterface :: Expr -> QualifiedClassName
closureTarget :: Expr -> MethodDescriptor
closureTargetMethod :: Expr -> Text
closureTargetClass :: Expr -> QualifiedClassName
..} -> do
        -- Emit captured values onto the stack
        [(Expr, FieldType)]
-> ((Expr, FieldType) -> Eff r (Maybe ClassInfoType)) -> Eff r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(Expr, FieldType)]
capturedValues (Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr (Expr -> Eff r (Maybe ClassInfoType))
-> ((Expr, FieldType) -> Expr)
-> (Expr, FieldType)
-> Eff r (Maybe ClassInfoType)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Expr, FieldType) -> Expr
forall a b. (a, b) -> a
fst)

        let capturedTypes :: [FieldType]
capturedTypes = ((Expr, FieldType) -> FieldType)
-> [(Expr, FieldType)] -> [FieldType]
forall a b. (a -> b) -> [a] -> [b]
map (Expr, FieldType) -> FieldType
forall a b. (a, b) -> b
snd [(Expr, FieldType)]
capturedValues
        let MethodDescriptor [FieldType]
originalArgTypes ReturnDescriptor
returnType = MethodDescriptor
closureTarget
        let capturedCount :: Int
capturedCount = [(Expr, FieldType)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Expr, FieldType)]
capturedValues
        let remainingArgTypes :: [FieldType]
remainingArgTypes = Int -> [FieldType] -> [FieldType]
forall a. Int -> [a] -> [a]
drop Int
capturedCount [FieldType]
originalArgTypes

        let implMethodHandle :: MethodHandleEntry
implMethodHandle =
                MethodRef -> MethodHandleEntry
MHInvokeStatic (MethodRef -> MethodHandleEntry) -> MethodRef -> MethodHandleEntry
forall a b. (a -> b) -> a -> b
$
                    ClassInfoType -> Text -> MethodDescriptor -> MethodRef
MethodRef
                        (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
closureTargetClass)
                        (Text -> Text
translateOperatorName Text
closureTargetMethod)
                        MethodDescriptor
closureTarget

        [FieldType]
-> [FieldType]
-> ReturnDescriptor
-> MethodHandleEntry
-> QualifiedClassName
-> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
[FieldType]
-> [FieldType]
-> ReturnDescriptor
-> MethodHandleEntry
-> QualifiedClassName
-> Eff r (Maybe ClassInfoType)
emitInvokeDynamic [FieldType]
capturedTypes [FieldType]
remainingArgTypes ReturnDescriptor
returnType MethodHandleEntry
implMethodHandle QualifiedClassName
closureInterface
    IR.MakeConstructorClosure{[(Expr, FieldType)]
QualifiedClassName
MethodDescriptor
ctorClosureClass :: QualifiedClassName
ctorClosureDesc :: MethodDescriptor
ctorClosureInterface :: QualifiedClassName
ctorCapturedValues :: [(Expr, FieldType)]
ctorCapturedValues :: Expr -> [(Expr, FieldType)]
ctorClosureInterface :: Expr -> QualifiedClassName
ctorClosureDesc :: Expr -> MethodDescriptor
ctorClosureClass :: Expr -> QualifiedClassName
..} -> do
        -- Emit captured values onto the stack
        [(Expr, FieldType)]
-> ((Expr, FieldType) -> Eff r (Maybe ClassInfoType)) -> Eff r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(Expr, FieldType)]
ctorCapturedValues (Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr (Expr -> Eff r (Maybe ClassInfoType))
-> ((Expr, FieldType) -> Expr)
-> (Expr, FieldType)
-> Eff r (Maybe ClassInfoType)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Expr, FieldType) -> Expr
forall a b. (a, b) -> a
fst)

        let capturedTypes :: [FieldType]
capturedTypes = ((Expr, FieldType) -> FieldType)
-> [(Expr, FieldType)] -> [FieldType]
forall a b. (a -> b) -> [a] -> [b]
map (Expr, FieldType) -> FieldType
forall a b. (a, b) -> b
snd [(Expr, FieldType)]
ctorCapturedValues
        let MethodDescriptor [FieldType]
originalArgTypes ReturnDescriptor
_ = MethodDescriptor
ctorClosureDesc
        let capturedCount :: Int
capturedCount = [(Expr, FieldType)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Expr, FieldType)]
ctorCapturedValues
        let remainingArgTypes :: [FieldType]
remainingArgTypes = Int -> [FieldType] -> [FieldType]
forall a. Int -> [a] -> [a]
drop Int
capturedCount [FieldType]
originalArgTypes
        let returnType :: ReturnDescriptor
returnType = FieldType -> ReturnDescriptor
TypeReturn (QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
ctorClosureClass)

        let implMethodHandle :: MethodHandleEntry
implMethodHandle =
                MethodRef -> MethodHandleEntry
MHNewInvokeSpecial (MethodRef -> MethodHandleEntry) -> MethodRef -> MethodHandleEntry
forall a b. (a -> b) -> a -> b
$
                    ClassInfoType -> Text -> MethodDescriptor -> MethodRef
MethodRef
                        (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
ctorClosureClass)
                        Text
"<init>"
                        MethodDescriptor
ctorClosureDesc

        [FieldType]
-> [FieldType]
-> ReturnDescriptor
-> MethodHandleEntry
-> QualifiedClassName
-> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
[FieldType]
-> [FieldType]
-> ReturnDescriptor
-> MethodHandleEntry
-> QualifiedClassName
-> Eff r (Maybe ClassInfoType)
emitInvokeDynamic [FieldType]
capturedTypes [FieldType]
remainingArgTypes ReturnDescriptor
returnType MethodHandleEntry
implMethodHandle QualifiedClassName
ctorClosureInterface
    IR.PrimOp PrimOp
op [Expr]
args -> do
        case (PrimOp
op, [Expr]
args) of
            (PrimOp
IR.UndefinedError, [Expr
msg]) -> do
                Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
msg
                Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$
                    ClassInfoType -> Text -> MethodDescriptor -> Instruction
forall label.
ClassInfoType -> Text -> MethodDescriptor -> Instruction' label
JVM.InvokeStatic
                        (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"Elara.Error")
                        Text
"undefined"
                        ([FieldType] -> ReturnDescriptor -> MethodDescriptor
MethodDescriptor [] (FieldType -> ReturnDescriptor
TypeReturn (FieldType -> ReturnDescriptor) -> FieldType -> ReturnDescriptor
forall a b. (a -> b) -> a -> b
$ QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
"java/lang/Object"))
                Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ClassInfoType -> Eff r (Maybe ClassInfoType))
-> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Maybe ClassInfoType
forall a. a -> Maybe a
Just (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"java/lang/Object")
            (PrimOp
IR.PatternMatchFailedError, []) -> do
                Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$
                    ClassInfoType -> Text -> MethodDescriptor -> Instruction
forall label.
ClassInfoType -> Text -> MethodDescriptor -> Instruction' label
JVM.InvokeStatic
                        (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"Elara.Error")
                        Text
"patternMatchFail"
                        ([FieldType] -> ReturnDescriptor -> MethodDescriptor
MethodDescriptor [] (FieldType -> ReturnDescriptor
TypeReturn (FieldType -> ReturnDescriptor) -> FieldType -> ReturnDescriptor
forall a b. (a -> b) -> a -> b
$ QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
"java/lang/Object"))
                Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ClassInfoType -> Eff r (Maybe ClassInfoType))
-> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Maybe ClassInfoType
forall a. a -> Maybe a
Just (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"java/lang/Object")
            (IR.CorePrim PrimOp
Prim.PrimIntAdd, [Expr
a, Expr
b]) -> Text -> Expr -> Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Text -> Expr -> Expr -> Eff r (Maybe ClassInfoType)
emitBinaryIntOp Text
"add" Expr
a Expr
b
            (IR.CorePrim PrimOp
Prim.PrimIntSubtract, [Expr
a, Expr
b]) -> Text -> Expr -> Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Text -> Expr -> Expr -> Eff r (Maybe ClassInfoType)
emitBinaryIntOp Text
"minus" Expr
a Expr
b
            (IR.CorePrim PrimOp
Prim.PrimIntMultiply, [Expr
a, Expr
b]) -> Text -> Expr -> Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Text -> Expr -> Expr -> Eff r (Maybe ClassInfoType)
emitBinaryIntOp Text
"times" Expr
a Expr
b
            (IR.CorePrim PrimOp
Prim.PrimIntDivide, [Expr
a, Expr
b]) -> Text -> Expr -> Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Text -> Expr -> Expr -> Eff r (Maybe ClassInfoType)
emitBinaryIntOp Text
"divide" Expr
a Expr
b
            (IR.CorePrim PrimOp
Prim.PrimIntRemainder, [Expr
a, Expr
b]) -> Text -> Expr -> Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Text -> Expr -> Expr -> Eff r (Maybe ClassInfoType)
emitBinaryIntOp Text
"remainder" Expr
a Expr
b
            (IR.CorePrim PrimOp
Prim.PrimIntNegate, [Expr
a]) -> do
                Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Text -> FieldType -> Instruction
forall label.
ClassInfoType -> Text -> FieldType -> Instruction' label
GetStatic (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"Elara.Prelude") Text
"negate" (QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
"Elara.Func")
                Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
a
                Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Text -> MethodDescriptor -> Instruction
forall label.
ClassInfoType -> Text -> MethodDescriptor -> Instruction' label
JVM.InvokeInterface (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"Elara.Func") Text
"run" ([FieldType] -> ReturnDescriptor -> MethodDescriptor
MethodDescriptor [FieldType
javaObject] (FieldType -> ReturnDescriptor
TypeReturn FieldType
javaObject))
                Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Instruction
forall label. ClassInfoType -> Instruction' label
CheckCast (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"java.lang.Integer")
                Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ClassInfoType -> Eff r (Maybe ClassInfoType))
-> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Maybe ClassInfoType
forall a. a -> Maybe a
Just (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"java.lang.Integer")
            (IR.CorePrim PrimOp
Prim.PrimPrintln, [Expr
msg]) -> do
                Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
msg
                Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Text -> MethodDescriptor -> Instruction
forall label.
ClassInfoType -> Text -> MethodDescriptor -> Instruction' label
JVM.InvokeStatic (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"Elara.IO") Text
"println" ([FieldType] -> ReturnDescriptor -> MethodDescriptor
MethodDescriptor [QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
"java.lang.Object"] (FieldType -> ReturnDescriptor
TypeReturn (QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
"Elara.IO")))
                Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ClassInfoType -> Eff r (Maybe ClassInfoType))
-> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Maybe ClassInfoType
forall a. a -> Maybe a
Just (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"Elara.IO")
            (IR.CorePrim PrimOp
Prim.PrimStringHead, [Expr
str]) -> Expr
-> Text
-> [FieldType]
-> QualifiedClassName
-> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr
-> Text
-> [FieldType]
-> QualifiedClassName
-> Eff r (Maybe ClassInfoType)
emitStringMethod Expr
str Text
"head" [] QualifiedClassName
"java.lang.Character"
            (IR.CorePrim PrimOp
Prim.PrimStringIsEmpty, [Expr
str]) -> do
                Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
str
                Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Text -> MethodDescriptor -> Instruction
forall label.
ClassInfoType -> Text -> MethodDescriptor -> Instruction' label
JVM.InvokeVirtual (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
stringTypeName) Text
"isEmpty" ([FieldType] -> ReturnDescriptor -> MethodDescriptor
MethodDescriptor [] (FieldType -> ReturnDescriptor
TypeReturn (FieldType -> ReturnDescriptor) -> FieldType -> ReturnDescriptor
forall a b. (a -> b) -> a -> b
$ PrimitiveType -> FieldType
PrimitiveFieldType PrimitiveType
JVM.JBoolean))
                Eff r (Maybe ClassInfoType)
forall (r :: [Effect]). EmitCode r => Eff r (Maybe ClassInfoType)
primitiveBooleanToElaraBoolean
            (IR.CorePrim PrimOp
Prim.PrimStringTail, [Expr
str]) -> Expr
-> Text
-> [FieldType]
-> QualifiedClassName
-> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr
-> Text
-> [FieldType]
-> QualifiedClassName
-> Eff r (Maybe ClassInfoType)
emitStringMethod Expr
str Text
"tail" [] QualifiedClassName
stringTypeName
            (IR.CorePrim PrimOp
Prim.PrimStringCons, [Expr
ch, Expr
str]) -> do
                Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
str -- receiver
                Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
ch -- argument
                Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Text -> MethodDescriptor -> Instruction
forall label.
ClassInfoType -> Text -> MethodDescriptor -> Instruction' label
JVM.InvokeVirtual (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
stringTypeName) Text
"cons" ([FieldType] -> ReturnDescriptor -> MethodDescriptor
MethodDescriptor [QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
"java.lang.Character"] (FieldType -> ReturnDescriptor
TypeReturn (FieldType -> ReturnDescriptor) -> FieldType -> ReturnDescriptor
forall a b. (a -> b) -> a -> b
$ QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
stringTypeName))
                Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ClassInfoType -> Eff r (Maybe ClassInfoType))
-> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Maybe ClassInfoType
forall a. a -> Maybe a
Just (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
stringTypeName)
            (IR.CorePrim PrimOp
Prim.PrimToString, [Expr
obj]) -> do
                Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
obj
                Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Text -> MethodDescriptor -> Instruction
forall label.
ClassInfoType -> Text -> MethodDescriptor -> Instruction' label
JVM.InvokeStatic (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"Elara.PrimOps") Text
"toString" ([FieldType] -> ReturnDescriptor -> MethodDescriptor
MethodDescriptor [QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
"java.lang.Object"] (FieldType -> ReturnDescriptor
TypeReturn (FieldType -> ReturnDescriptor) -> FieldType -> ReturnDescriptor
forall a b. (a -> b) -> a -> b
$ QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
stringTypeName))
                Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ClassInfoType -> Eff r (Maybe ClassInfoType))
-> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Maybe ClassInfoType
forall a. a -> Maybe a
Just (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
stringTypeName)
            (IR.CorePrim PrimOp
Prim.PrimEquals, [Expr
a, Expr
b]) -> do
                Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
a
                Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
b
                Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Text -> MethodDescriptor -> Instruction
forall label.
ClassInfoType -> Text -> MethodDescriptor -> Instruction' label
JVM.InvokeStatic (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"java.util.Objects") Text
"equals" MethodDescriptor
objectsEqualsDesc
                Eff r (Maybe ClassInfoType)
forall (r :: [Effect]). EmitCode r => Eff r (Maybe ClassInfoType)
primitiveBooleanToElaraBoolean
            (IR.CorePrim PrimOp
Prim.PrimCompare, [Expr
a, Expr
b]) -> do
                Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
a
                Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
b
                Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Text -> MethodDescriptor -> Instruction
forall label.
ClassInfoType -> Text -> MethodDescriptor -> Instruction' label
JVM.InvokeStatic (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"Elara.PrimOps") Text
"compare" ([FieldType] -> ReturnDescriptor -> MethodDescriptor
MethodDescriptor [FieldType
javaObject, FieldType
javaObject] (FieldType -> ReturnDescriptor
TypeReturn (FieldType -> ReturnDescriptor) -> FieldType -> ReturnDescriptor
forall a b. (a -> b) -> a -> b
$ QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
"java.lang.Integer"))
                Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ClassInfoType -> Eff r (Maybe ClassInfoType))
-> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Maybe ClassInfoType
forall a. a -> Maybe a
Just (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"java.lang.Integer")
            (IR.CorePrim PrimOp
Prim.PrimIOBind, [Expr
io, Expr
func]) -> do
                Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
io
                Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
func
                Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Text -> MethodDescriptor -> Instruction
forall label.
ClassInfoType -> Text -> MethodDescriptor -> Instruction' label
JVM.InvokeVirtual (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"Elara.IO") Text
"bind" ([FieldType] -> ReturnDescriptor -> MethodDescriptor
MethodDescriptor [QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
"Elara.Func"] (FieldType -> ReturnDescriptor
TypeReturn (FieldType -> ReturnDescriptor) -> FieldType -> ReturnDescriptor
forall a b. (a -> b) -> a -> b
$ QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
"Elara.IO"))
                Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ClassInfoType -> Eff r (Maybe ClassInfoType))
-> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Maybe ClassInfoType
forall a. a -> Maybe a
Just (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"Elara.IO")
            (IR.CorePrim PrimOp
Prim.PrimDebugWithMsg, [Expr
msg, Expr
value]) -> do
                Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
msg
                Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
value
                Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Text -> MethodDescriptor -> Instruction
forall label.
ClassInfoType -> Text -> MethodDescriptor -> Instruction' label
JVM.InvokeStatic (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"Elara.PrimOps") Text
"debugWithMsg" ([FieldType] -> ReturnDescriptor -> MethodDescriptor
MethodDescriptor [QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
stringTypeName, FieldType
javaObject] (FieldType -> ReturnDescriptor
TypeReturn FieldType
javaObject))
                Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ClassInfoType -> Eff r (Maybe ClassInfoType))
-> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Maybe ClassInfoType
forall a. a -> Maybe a
Just (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"java.lang.Object")
            (IR.CorePrim PrimOp
Prim.PrimThrowError, [Expr
msg]) -> do
                Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
msg
                Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Text -> MethodDescriptor -> Instruction
forall label.
ClassInfoType -> Text -> MethodDescriptor -> Instruction' label
JVM.InvokeStatic (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"Elara.PrimOps") Text
"toString" ([FieldType] -> ReturnDescriptor -> MethodDescriptor
MethodDescriptor [FieldType
javaObject] (FieldType -> ReturnDescriptor
TypeReturn (FieldType -> ReturnDescriptor) -> FieldType -> ReturnDescriptor
forall a b. (a -> b) -> a -> b
$ QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
stringTypeName))
                Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Text -> MethodDescriptor -> Instruction
forall label.
ClassInfoType -> Text -> MethodDescriptor -> Instruction' label
JVM.InvokeStatic (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"Elara.Error") Text
"throwError" ([FieldType] -> ReturnDescriptor -> MethodDescriptor
MethodDescriptor [QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
stringTypeName] (FieldType -> ReturnDescriptor
TypeReturn FieldType
javaObject))
                Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ClassInfoType -> Eff r (Maybe ClassInfoType))
-> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Maybe ClassInfoType
forall a. a -> Maybe a
Just (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"java/lang/Object")
            (IR.CorePrim PrimOp
Prim.PrimReadFile, [Expr
path]) -> do
                Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
path
                Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Text -> MethodDescriptor -> Instruction
forall label.
ClassInfoType -> Text -> MethodDescriptor -> Instruction' label
JVM.InvokeStatic (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"Elara.PrimOps") Text
"readFile" ([FieldType] -> ReturnDescriptor -> MethodDescriptor
MethodDescriptor [QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
stringTypeName] (FieldType -> ReturnDescriptor
TypeReturn (FieldType -> ReturnDescriptor) -> FieldType -> ReturnDescriptor
forall a b. (a -> b) -> a -> b
$ QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
"Elara/IO"))
                Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ClassInfoType -> Eff r (Maybe ClassInfoType))
-> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Maybe ClassInfoType
forall a. a -> Maybe a
Just (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"Elara/IO")
            (IR.CorePrim PrimOp
Prim.PrimGetArgs, [Expr]
_) -> do
                Text -> Eff r (Maybe ClassInfoType)
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"emitExpr: PrimGetArgs should have been handled by lowering"
            (PrimOp, [Expr])
other -> Text -> Eff r (Maybe ClassInfoType)
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Eff r (Maybe ClassInfoType))
-> Text -> Eff r (Maybe ClassInfoType)
forall a b. (a -> b) -> a -> b
$ Text
"emitExpr: Unhandled primitive operation: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (PrimOp, [Expr]) -> Text
forall a. Pretty a => a -> Text
prettyToText (PrimOp, [Expr])
other
    IR.New QualifiedClassName
className [(Expr, FieldType)]
args -> do
        Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Instruction
forall label. ClassInfoType -> Instruction' label
JVM.New (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
className)
        Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit Instruction
forall label. Instruction' label
JVM.Dup
        [(Expr, FieldType)]
-> ((Expr, FieldType) -> Eff r (Maybe ClassInfoType)) -> Eff r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(Expr, FieldType)]
args (Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr (Expr -> Eff r (Maybe ClassInfoType))
-> ((Expr, FieldType) -> Expr)
-> (Expr, FieldType)
-> Eff r (Maybe ClassInfoType)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Expr, FieldType) -> Expr
forall a b. (a, b) -> a
fst)
        let argTypes :: [FieldType]
argTypes = ((Expr, FieldType) -> FieldType)
-> [(Expr, FieldType)] -> [FieldType]
forall a b. (a -> b) -> [a] -> [b]
map (Expr, FieldType) -> FieldType
forall a b. (a, b) -> b
snd [(Expr, FieldType)]
args
        Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Text -> MethodDescriptor -> Instruction
forall label.
ClassInfoType -> Text -> MethodDescriptor -> Instruction' label
JVM.InvokeSpecial (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
className) Text
"<init>" ([FieldType] -> ReturnDescriptor -> MethodDescriptor
MethodDescriptor [FieldType]
argTypes ReturnDescriptor
VoidReturn)
        Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ClassInfoType -> Eff r (Maybe ClassInfoType))
-> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Maybe ClassInfoType
forall a. a -> Maybe a
Just (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
className)
    IR.Cast Expr
expr FieldType
targetType -> do
        Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
expr
        Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Instruction
forall label. ClassInfoType -> Instruction' label
JVM.CheckCast (FieldType -> ClassInfoType
fieldTypeToClassInfoType FieldType
targetType)
        Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ClassInfoType -> Eff r (Maybe ClassInfoType))
-> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Maybe ClassInfoType
forall a. a -> Maybe a
Just (FieldType -> ClassInfoType
fieldTypeToClassInfoType FieldType
targetType)
    IR.ArrayLength Expr
arr -> do
        Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
arr
        Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit Instruction
forall label. Instruction' label
JVM.ArrayLength
        Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ClassInfoType -> Eff r (Maybe ClassInfoType))
-> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Maybe ClassInfoType
forall a. a -> Maybe a
Just (PrimitiveType -> ClassInfoType
PrimitiveClassInfoType PrimitiveType
JVM.JInt)
    IR.ArrayLoad Expr
arr FieldType
arrTy Expr
idx -> do
        Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
arr
        Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
idx
        Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit Instruction
forall label. Instruction' label
JVM.AALoad
        Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ClassInfoType -> Eff r (Maybe ClassInfoType))
-> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Maybe ClassInfoType
forall a. a -> Maybe a
Just (FieldType -> ClassInfoType
fieldTypeToClassInfoType FieldType
arrTy)
    IR.PrimitiveIntOp PrimBinOp
op Expr
a Expr
b -> case PrimBinOp
op of
        PrimBinOp
IR.PrimAdd -> do
            Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
a
            Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
b
            Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit Instruction
forall label. Instruction' label
JVM.IAdd
            Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ClassInfoType -> Eff r (Maybe ClassInfoType))
-> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Maybe ClassInfoType
forall a. a -> Maybe a
Just (PrimitiveType -> ClassInfoType
PrimitiveClassInfoType PrimitiveType
JVM.JInt)
        PrimBinOp
IR.PrimSubtract -> do
            Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
a
            Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
b
            Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit Instruction
forall label. Instruction' label
JVM.ISub
            Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ClassInfoType -> Eff r (Maybe ClassInfoType))
-> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Maybe ClassInfoType
forall a. a -> Maybe a
Just (PrimitiveType -> ClassInfoType
PrimitiveClassInfoType PrimitiveType
JVM.JInt)
        PrimBinOp
IR.PrimMultiply -> do
            Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
a
            Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
b
            Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit Instruction
forall label. Instruction' label
JVM.IMul
            Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ClassInfoType -> Eff r (Maybe ClassInfoType))
-> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Maybe ClassInfoType
forall a. a -> Maybe a
Just (PrimitiveType -> ClassInfoType
PrimitiveClassInfoType PrimitiveType
JVM.JInt)
        PrimBinOp
IR.PrimDivide -> do
            Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
a
            Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
b
            Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit Instruction
forall label. Instruction' label
JVM.IDiv
            Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ClassInfoType -> Eff r (Maybe ClassInfoType))
-> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Maybe ClassInfoType
forall a. a -> Maybe a
Just (PrimitiveType -> ClassInfoType
PrimitiveClassInfoType PrimitiveType
JVM.JInt)
        PrimBinOp
IR.PrimGT -> do
            Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
a
            Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
b
            trueLabel <- Eff r Label
forall {k} (es :: [Effect]).
(HasCallStack, CodeBuilder :> es) =>
Eff es Label
newLabel
            endLabel <- newLabel
            emit $ JVM.IfICmp (IfGt trueLabel)
            emit JVM.IConst0
            emit $ Goto endLabel
            emit $ JVM.Label trueLabel
            emit JVM.IConst1
            emit $ JVM.Label endLabel
            pure $ Just (PrimitiveClassInfoType JVM.JBoolean)
    Expr
_ -> Text -> Eff r (Maybe ClassInfoType)
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Eff r (Maybe ClassInfoType))
-> Text -> Eff r (Maybe ClassInfoType)
forall a b. (a -> b) -> a -> b
$ Text
"emitExpr: Unhandled expression: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Expr -> Text
forall a. Pretty a => a -> Text
prettyToText Expr
expr

-- | Common type aliases for Java types
javaObject :: FieldType
javaObject :: FieldType
javaObject = QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
"java.lang.Object"

objectsEqualsDesc :: MethodDescriptor
objectsEqualsDesc :: MethodDescriptor
objectsEqualsDesc = [FieldType] -> ReturnDescriptor -> MethodDescriptor
MethodDescriptor [FieldType
javaObject, FieldType
javaObject] (FieldType -> ReturnDescriptor
TypeReturn (FieldType -> ReturnDescriptor) -> FieldType -> ReturnDescriptor
forall a b. (a -> b) -> a -> b
$ PrimitiveType -> FieldType
PrimitiveFieldType PrimitiveType
JVM.JBoolean)

-- | Emit a binary integer operation using a curried Prelude function
emitBinaryIntOp :: EmitCode r => Text -> IR.Expr -> IR.Expr -> Eff r (Maybe ClassInfoType)
emitBinaryIntOp :: forall (r :: [Effect]).
EmitCode r =>
Text -> Expr -> Expr -> Eff r (Maybe ClassInfoType)
emitBinaryIntOp Text
funcName Expr
a Expr
b = do
    -- Get the curried function: Prelude.funcName : Int -> Int -> Int
    Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Text -> FieldType -> Instruction
forall label.
ClassInfoType -> Text -> FieldType -> Instruction' label
GetStatic (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"Elara.Prelude") Text
funcName (QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
"Elara.Func")
    -- Apply first argument: stack is [func], need [func, a] -> [add_a]
    Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
a
    Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Text -> MethodDescriptor -> Instruction
forall label.
ClassInfoType -> Text -> MethodDescriptor -> Instruction' label
JVM.InvokeInterface (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"Elara.Func") Text
"run" ([FieldType] -> ReturnDescriptor -> MethodDescriptor
MethodDescriptor [FieldType
javaObject] (FieldType -> ReturnDescriptor
TypeReturn FieldType
javaObject))
    -- Apply second argument: stack is [add_a], need [add_a, b] -> [result]
    Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
b
    Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Text -> MethodDescriptor -> Instruction
forall label.
ClassInfoType -> Text -> MethodDescriptor -> Instruction' label
JVM.InvokeInterface (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"Elara.Func") Text
"run" ([FieldType] -> ReturnDescriptor -> MethodDescriptor
MethodDescriptor [FieldType
javaObject] (FieldType -> ReturnDescriptor
TypeReturn FieldType
javaObject))
    Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Instruction
forall label. ClassInfoType -> Instruction' label
CheckCast (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"java.lang.Integer")
    Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ClassInfoType -> Eff r (Maybe ClassInfoType))
-> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Maybe ClassInfoType
forall a. a -> Maybe a
Just (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"java.lang.Integer")

-- | Emit a method call on Elara.String
emitStringMethod :: EmitCode r => IR.Expr -> Text -> [FieldType] -> QualifiedClassName -> Eff r (Maybe ClassInfoType)
emitStringMethod :: forall (r :: [Effect]).
EmitCode r =>
Expr
-> Text
-> [FieldType]
-> QualifiedClassName
-> Eff r (Maybe ClassInfoType)
emitStringMethod Expr
receiver Text
methodName [FieldType]
argTypes QualifiedClassName
retTypeName = do
    Expr -> Eff r (Maybe ClassInfoType)
forall (r :: [Effect]).
EmitCode r =>
Expr -> Eff r (Maybe ClassInfoType)
emitExpr Expr
receiver
    Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Text -> MethodDescriptor -> Instruction
forall label.
ClassInfoType -> Text -> MethodDescriptor -> Instruction' label
JVM.InvokeVirtual (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
stringTypeName) Text
methodName ([FieldType] -> ReturnDescriptor -> MethodDescriptor
MethodDescriptor [FieldType]
argTypes (FieldType -> ReturnDescriptor
TypeReturn (FieldType -> ReturnDescriptor) -> FieldType -> ReturnDescriptor
forall a b. (a -> b) -> a -> b
$ QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
retTypeName))
    Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ClassInfoType -> Eff r (Maybe ClassInfoType))
-> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Maybe ClassInfoType
forall a. a -> Maybe a
Just (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
retTypeName)

-- | Emit invokedynamic for closure creation (shared between MakeClosure and MakeConstructorClosure)
emitInvokeDynamic ::
    EmitCode r =>
    -- | captured types
    [FieldType] ->
    -- | remaining arg types
    [FieldType] ->
    -- | return type
    ReturnDescriptor ->
    -- | implementation method handle
    MethodHandleEntry ->
    -- | target interface
    QualifiedClassName ->
    Eff r (Maybe ClassInfoType)
emitInvokeDynamic :: forall (r :: [Effect]).
EmitCode r =>
[FieldType]
-> [FieldType]
-> ReturnDescriptor
-> MethodHandleEntry
-> QualifiedClassName
-> Eff r (Maybe ClassInfoType)
emitInvokeDynamic [FieldType]
capturedTypes [FieldType]
remainingArgTypes ReturnDescriptor
returnType MethodHandleEntry
implMethodHandle QualifiedClassName
targetInterface = do
    let specializedDesc :: MethodDescriptor
specializedDesc = [FieldType] -> ReturnDescriptor -> MethodDescriptor
MethodDescriptor [FieldType]
remainingArgTypes ReturnDescriptor
returnType
    let erasedDesc :: MethodDescriptor
erasedDesc = [FieldType] -> ReturnDescriptor -> MethodDescriptor
MethodDescriptor (Int -> FieldType -> [FieldType]
forall a. Int -> a -> [a]
replicate ([FieldType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FieldType]
remainingArgTypes) FieldType
javaObject) (FieldType -> ReturnDescriptor
TypeReturn FieldType
javaObject)

    let bootstrapMethodHandle :: MethodHandleEntry
bootstrapMethodHandle =
            MethodRef -> MethodHandleEntry
MHInvokeStatic (MethodRef -> MethodHandleEntry) -> MethodRef -> MethodHandleEntry
forall a b. (a -> b) -> a -> b
$
                ClassInfoType -> Text -> MethodDescriptor -> MethodRef
MethodRef
                    (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"java/lang/invoke/LambdaMetafactory")
                    Text
"metafactory"
                    ( [FieldType] -> ReturnDescriptor -> MethodDescriptor
MethodDescriptor
                        [ QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
"java/lang/invoke/MethodHandles$Lookup"
                        , QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
"java/lang/String"
                        , QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
"java/lang/invoke/MethodType"
                        , QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
"java/lang/invoke/MethodType"
                        , QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
"java/lang/invoke/MethodHandle"
                        , QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
"java/lang/invoke/MethodType"
                        ]
                        (FieldType -> ReturnDescriptor
TypeReturn (FieldType -> ReturnDescriptor) -> FieldType -> ReturnDescriptor
forall a b. (a -> b) -> a -> b
$ QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
"java/lang/invoke/CallSite")
                    )

    let bootstrapMethod :: BootstrapMethod
bootstrapMethod =
            MethodHandleEntry -> [BootstrapArgument] -> BootstrapMethod
BootstrapMethod
                MethodHandleEntry
bootstrapMethodHandle
                [ MethodDescriptor -> BootstrapArgument
BMMethodArg MethodDescriptor
erasedDesc
                , MethodHandleEntry -> BootstrapArgument
BMMethodHandleArg MethodHandleEntry
implMethodHandle
                , MethodDescriptor -> BootstrapArgument
BMMethodArg MethodDescriptor
specializedDesc
                ]

    let invokedTypeDesc :: MethodDescriptor
invokedTypeDesc = [FieldType] -> ReturnDescriptor -> MethodDescriptor
MethodDescriptor [FieldType]
capturedTypes (FieldType -> ReturnDescriptor
TypeReturn (QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
targetInterface))
    Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ BootstrapMethod -> Text -> MethodDescriptor -> Instruction
forall label.
BootstrapMethod -> Text -> MethodDescriptor -> Instruction' label
InvokeDynamic BootstrapMethod
bootstrapMethod Text
"run" MethodDescriptor
invokedTypeDesc
    Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ClassInfoType -> Eff r (Maybe ClassInfoType))
-> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Maybe ClassInfoType
forall a. a -> Maybe a
Just (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
targetInterface)

rethrowError ::
    (HasCallStack, Eff.Error JVMLoweringError :> es) =>
    Eff (Eff.Error StackMapError : es) a ->
    Eff es a
rethrowError :: forall (es :: [Effect]) a.
(HasCallStack, Error JVMLoweringError :> es) =>
Eff (Error StackMapError : es) a -> Eff es a
rethrowError Eff (Error StackMapError : es) a
action =
    forall e (es :: [Effect]) a.
HasCallStack =>
Eff (Error e : es) a -> Eff es (Either e a)
Eff.runErrorNoCallStack @StackMapError Eff (Error StackMapError : es) a
action Eff es (Either StackMapError a)
-> (Either StackMapError a -> Eff es a) -> Eff es a
forall a b. Eff es a -> (a -> Eff es b) -> Eff es b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left StackMapError
e -> JVMLoweringError -> Eff es a
forall e (es :: [Effect]) a.
(HasCallStack, Error e :> es, Show e) =>
e -> Eff es a
throwError (StackMapError -> JVMLoweringError
H2JVMError StackMapError
e)
        Right a
a -> a -> Eff es a
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

emitJVMMainMethod :: (StructuredDebug :> r, ClassBuilder :> r, Eff.Error JVMLoweringError :> r) => QualifiedClassName -> Eff r ()
emitJVMMainMethod :: forall (r :: [Effect]).
(StructuredDebug :> r, ClassBuilder :> r,
 Error JVMLoweringError :> r) =>
QualifiedClassName -> Eff r ()
emitJVMMainMethod QualifiedClassName
thisClassName = do
    let elaraIOClass :: QualifiedClassName
        elaraIOClass :: QualifiedClassName
elaraIOClass = QualifiedClassName
"Elara/IO"

        -- elara Main.main() : Elara.IO
        elaraMainDesc :: MethodDescriptor
elaraMainDesc =
            [FieldType] -> ReturnDescriptor -> MethodDescriptor
MethodDescriptor [] (FieldType -> ReturnDescriptor
TypeReturn (QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
elaraIOClass))

        javaMainDesc :: MethodDescriptor
javaMainDesc =
            [FieldType] -> ReturnDescriptor -> MethodDescriptor
MethodDescriptor
                [FieldType -> FieldType
ArrayFieldType (QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
"java/lang/String")]
                ReturnDescriptor
VoidReturn

    Eff (Error StackMapError : r) () -> Eff r ()
forall (es :: [Effect]) a.
(HasCallStack, Error JVMLoweringError :> es) =>
Eff (Error StackMapError : es) a -> Eff es a
rethrowError (Eff (Error StackMapError : r) () -> Eff r ())
-> Eff (Error StackMapError : r) () -> Eff r ()
forall a b. (a -> b) -> a -> b
$ Text
-> [MethodAccessFlag]
-> MethodDescriptor
-> Eff (CodeBuilder : Error StackMapError : r) ()
-> Eff (Error StackMapError : r) ()
forall (r :: [Effect]) a.
(ClassBuilder :> r, Error StackMapError :> r, HasCallStack) =>
Text
-> [MethodAccessFlag]
-> MethodDescriptor
-> Eff (CodeBuilder : r) a
-> Eff r a
addMethodWithCode Text
"main" [MethodAccessFlag
MPublic, MethodAccessFlag
MStatic] MethodDescriptor
javaMainDesc (Eff (CodeBuilder : Error StackMapError : r) ()
 -> Eff (Error StackMapError : r) ())
-> Eff (CodeBuilder : Error StackMapError : r) ()
-> Eff (Error StackMapError : r) ()
forall a b. (a -> b) -> a -> b
$ do
        -- load args
        Instruction -> Eff (CodeBuilder : Error StackMapError : r) ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff (CodeBuilder : Error StackMapError : r) ())
-> Instruction -> Eff (CodeBuilder : Error StackMapError : r) ()
forall a b. (a -> b) -> a -> b
$ U2 -> Instruction
forall label. U2 -> Instruction' label
ALoad U2
0
        -- call Elara.RuntimeSystem.init(String[] args) : void
        Instruction -> Eff (CodeBuilder : Error StackMapError : r) ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff (CodeBuilder : Error StackMapError : r) ())
-> Instruction -> Eff (CodeBuilder : Error StackMapError : r) ()
forall a b. (a -> b) -> a -> b
$
            ClassInfoType -> Text -> MethodDescriptor -> Instruction
forall label.
ClassInfoType -> Text -> MethodDescriptor -> Instruction' label
JVM.InvokeStatic
                (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"Elara.RuntimeSystem")
                Text
"init"
                ([FieldType] -> ReturnDescriptor -> MethodDescriptor
MethodDescriptor [FieldType -> FieldType
ArrayFieldType (QualifiedClassName -> FieldType
ObjectFieldType QualifiedClassName
"java/lang/String")] ReturnDescriptor
VoidReturn)

        -- Call Elara Main.main() : Elara.IO
        Instruction -> Eff (CodeBuilder : Error StackMapError : r) ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff (CodeBuilder : Error StackMapError : r) ())
-> Instruction -> Eff (CodeBuilder : Error StackMapError : r) ()
forall a b. (a -> b) -> a -> b
$
            ClassInfoType -> Text -> MethodDescriptor -> Instruction
forall label.
ClassInfoType -> Text -> MethodDescriptor -> Instruction' label
JVM.InvokeStatic
                (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
thisClassName)
                Text
"main"
                MethodDescriptor
elaraMainDesc

        -- Call IO#run() : void
        Instruction -> Eff (CodeBuilder : Error StackMapError : r) ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff (CodeBuilder : Error StackMapError : r) ())
-> Instruction -> Eff (CodeBuilder : Error StackMapError : r) ()
forall a b. (a -> b) -> a -> b
$
            ClassInfoType -> Text -> MethodDescriptor -> Instruction
forall label.
ClassInfoType -> Text -> MethodDescriptor -> Instruction' label
JVM.InvokeVirtual
                (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
elaraIOClass)
                Text
"run"
                ([FieldType] -> ReturnDescriptor -> MethodDescriptor
MethodDescriptor [] ReturnDescriptor
VoidReturn)

        Instruction -> Eff (CodeBuilder : Error StackMapError : r) ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit Instruction
forall label. Instruction' label
JVM.Return

convertMaxStackOrLocals :: source -> (source -> a) -> Eff es a
convertMaxStackOrLocals source
n source -> a
errorConstructor
    | source
n source -> source -> Bool
forall a. Ord a => a -> a -> Bool
<= U2 -> source
forall a b. (Integral a, Num b) => a -> b
fromIntegral (U2
forall a. Bounded a => a
maxBound :: U2) = a -> Eff es a
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (source -> a
forall target source.
(HasCallStack, TryFrom source target, Show source, Typeable source,
 Typeable target) =>
source -> target
unsafeInto source
n)
    | Bool
otherwise = a -> Eff es a
forall e (es :: [Effect]) a.
(HasCallStack, Error e :> es, Show e) =>
e -> Eff es a
throwError (a -> Eff es a) -> a -> Eff es a
forall a b. (a -> b) -> a -> b
$ source -> a
errorConstructor source
n

-- | Emit an Elara boolean (True or False) onto the stack
emitElaraBool :: EmitCode r => Bool -> Eff r (Maybe ClassInfoType)
emitElaraBool :: forall (r :: [Effect]).
EmitCode r =>
Bool -> Eff r (Maybe ClassInfoType)
emitElaraBool Bool
b = do
    let className :: QualifiedClassName
className = if Bool
b then QualifiedClassName
"Elara.Prim.True" else QualifiedClassName
"Elara.Prim.False"
    Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Instruction
forall label. ClassInfoType -> Instruction' label
JVM.New (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
className)
    Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit Instruction
forall label. Instruction' label
JVM.Dup
    Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Text -> MethodDescriptor -> Instruction
forall label.
ClassInfoType -> Text -> MethodDescriptor -> Instruction' label
JVM.InvokeSpecial (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
className) Text
"<init>" ([FieldType] -> ReturnDescriptor -> MethodDescriptor
MethodDescriptor [] ReturnDescriptor
VoidReturn)
    Instruction -> Eff r ()
forall (r :: [Effect]).
(CodeBuilder :> r) =>
Instruction -> Eff r ()
emit (Instruction -> Eff r ()) -> Instruction -> Eff r ()
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Instruction
forall label. ClassInfoType -> Instruction' label
CheckCast (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"Elara.Prim.Bool")
    Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a. a -> Eff r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ClassInfoType -> Eff r (Maybe ClassInfoType))
-> Maybe ClassInfoType -> Eff r (Maybe ClassInfoType)
forall a b. (a -> b) -> a -> b
$ ClassInfoType -> Maybe ClassInfoType
forall a. a -> Maybe a
Just (QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
"Elara.Prim.Bool")

-- | Convert a primitive boolean (int 0 or 1) on the stack to an Elara.Prim.Bool
primitiveBooleanToElaraBoolean :: EmitCode r => Eff r (Maybe ClassInfoType)
primitiveBooleanToElaraBoolean :: forall (r :: [Effect]). EmitCode r => Eff r (Maybe ClassInfoType)
primitiveBooleanToElaraBoolean = do
    falseLabel <- Eff r Label
forall {k} (es :: [Effect]).
(HasCallStack, CodeBuilder :> es) =>
Eff es Label
newLabel
    endLabel <- newLabel
    emit $ If $ IfEq falseLabel
    -- true case
    void $ emitElaraBool True
    emit $ Goto endLabel
    -- false case
    emit $ JVM.Label falseLabel
    void $ emitElaraBool False
    emit $ JVM.Label endLabel
    pure $ Just (ClassInfoType "Elara.Prim.Bool")