{-# LANGUAGE OverloadedStrings #-}

module Scheme.LLVM.Runtime (runtime) where

import qualified LLVM.General.AST as AST
import qualified LLVM.General.AST.Type as T 
import qualified Scheme.LLVM.Types as S

import qualified LLVM.General.AST.IntegerPredicate as IP
import LLVM.General.AST.AddrSpace (AddrSpace(..))
import Control.Lens ((.=))
import Control.Monad
import LLVM.Gen


runtime :: AST.Module
runtime = mapLLVM . runLLVM defaultModule $ do 


  moduleName .= "Runtime"


  defn S.schValPtr "init_num" [(T.double, "value", 8)] $ do
    sNumber <- alloca S.schVal 16
    numberType  <- getElemPtr' S.schValPtr sNumber [i32 0, i32 0]
    numberValue <- getElemPtr' S.schValPtr sNumber [i32 0, i32 1]

    value <- getvar' "value" >>= load T.double 8
    store T.i32    4 S.numberType numberType
    store T.double 4 value numberValue
    ret sNumber

    
  defn S.schValPtr "init_err" [] $ do 
    sError <- alloca S.schVal 16
    errType <- getElemPtr' S.schValPtr sError [i32 0, i32 0]
    store T.i32 4 S.errorType errType
    ret sError


  let if_args = [(S.fnImplPtr, "value", 8), (S.schValPtrs, "closed", 8)]

  defn S.schValPtr "init_fn" if_args $ do
    sFunc <- alloca S.schVal 16
    fnType  <- getElemPtr' S.schValPtr sFunc [i32 0, i32 0]  
    fnValue <- getElemPtr' S.schValPtr sFunc [i32 0, i32 1]

    funcValue   <- getvar' "value"
    f64PtrValue <- bitcast (S.ptr T.double) funcValue
    value       <- load S.fnImpl 8 f64PtrValue

    store T.i32 4 S.numberType fnType
    store T.double 4 value fnValue
    ret sFunc


  let args = [(S.schValPtr, "value", 8), (S.schValPtrs, "args", 8)]

  defn S.schValPtr "call_fn" args $ do
    ifthen <- addBlock "if.then"
    ifelse <- addBlock "if.else"
    ifexit <- addBlock "if.exit"

    func <- getvar' "value" >>= load S.schValPtr 8
    objectTPtr <- getElemPtr' S.schValPtr func [i32 0, i32 0] 
    objectType <- load (S.ptr T.i32) 8 objectTPtr

    comp <- icmp IP.EQ S.functionType objectType
    cbr comp ifthen ifelse

    let init_err = externf S.fnImplPtr (AST.Name "init_err")

    setBlock ifthen
    objectVPtr <- getElemPtr' S.schValPtr func [i32 0, i32 1]
    sFunctionP <- bitcast (S.ptr S.schemeFn) objectVPtr
    closedPtr <- getElemPtr' (S.ptr S.schemeFn) sFunctionP [i32 0, i32 0]
    functnPtr <- getElemPtr' (S.ptr S.schemeFn) sFunctionP [i32 0, i32 1]
    closedV <- load S.schValPtrs 8 closedPtr
    functnV <- load (S.ptr S.schemeFn) 8 functnPtr
    arguments <- getvar' "args" >>= load S.schValPtrs 8
    result <- call S.schValPtr functnV [closedV, arguments]
    br ifexit
    ifthen <- getBlock

    setBlock ifelse
    typeError <- call S.schValPtr init_err []

    br ifexit
    ifelse <- getBlock

    setBlock ifexit
    result <- phi S.schValPtr [(result, ifthen), (typeError, ifelse)]
    ret result 


