Execution.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
module Synthesizer.LLVM.Execution where

import qualified LLVM.ExecutionEngine as EE
import qualified LLVM.Util.Optimize as Opt
import qualified LLVM.Core as LLVM

import Foreign.Ptr (FunPtr, )

import qualified Control.Monad.Trans.Reader as R
import Control.Monad (liftM2, liftM3, )

import qualified Data.IORef as IORef
import System.IO.Unsafe (unsafePerformIO, )

import qualified Synthesizer.LLVM.Debug.Counter as Counter


type Importer f = FunPtr f -> f

class Compile externFunction llvmFunction |
                    externFunction -> llvmFunction,
                    llvmFunction -> externFunction where
   compile :: llvmFunction -> EE.EngineAccess externFunction

instance Compile (FunPtr f) (LLVM.Function f) where
   compile = EE.getPointerToFunction

instance (Compile efa lfa, Compile efb lfb) =>
      Compile (efa,efb) (lfa,lfb) where
   compile (fa,fb) =
      liftM2 (,)
         (compile fa)
         (compile fb)

instance (Compile efa lfa, Compile efb lfb, Compile efc lfc) =>
      Compile (efa,efb,efc) (lfa,lfb,lfc) where
   compile (fa,fb,fc) =
      liftM3 (,,)
         (compile fa)
         (compile fb)
         (compile fc)


data BitCodeCnt = BitCodeCnt

{- |
This is only for debugging purposes
and thus I felt free to use unsafePerformIO.
-}
counter :: IORef.IORef (Counter.T BitCodeCnt)
counter =
   unsafePerformIO $ Counter.new


{- |
This function also initializes LLVM.
This simplifies usage from GHCi.
The @llvm@ packages prevents multiple initialization.
-}
assembleModule ::
   (llvmFunction -> EE.EngineAccess externFunction) ->
   LLVM.CodeGenModule llvmFunction ->
   IO externFunction
assembleModule comp bld = do
   LLVM.initializeNativeTarget
   m <- LLVM.newModule
   (funcs, mappings) <-
      LLVM.defineModule m (liftM2 (,) bld LLVM.getGlobalMappings)

   Counter.with counter $ R.ReaderT $ \cnt -> do
      LLVM.writeBitcodeToFile ("generator" ++ Counter.format 3 cnt ++ ".bc") m
      _ <- Opt.optimizeModule 3 m
      LLVM.writeBitcodeToFile ("generator" ++ Counter.format 3 cnt ++ "-opt.bc") m

   EE.runEngineAccess $
      EE.addModule m >>
      EE.addGlobalMappings mappings >>
      comp funcs


-- this compiles once and is much faster than runFunction
compileModule ::
   (Compile externFunction llvmFunction) =>
   LLVM.CodeGenModule llvmFunction ->
   IO externFunction
compileModule =
   assembleModule compile

runFunction ::
   (EE.Translatable f) =>
   LLVM.CodeGenModule (LLVM.Function f) -> IO f
runFunction =
   assembleModule EE.generateFunction