Execution.hs

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

import LLVM.Core
   (CodeGenModule, newModule, defineModule, getGlobalMappings, Function,
    writeBitcodeToFile, )
import LLVM.ExecutionEngine
   (EngineAccess, runEngineAccess,
    Translatable, generateFunction,
    addModule, getPointerToFunction, addGlobalMappings, )
import LLVM.Util.Optimize (optimizeModule, )

import Foreign.Ptr (FunPtr, )

import Control.Monad (liftM2, liftM3, )

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


type Importer f = FunPtr f -> f

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

instance Compile (FunPtr f) (Function f) where
   compile = 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)


{- |
This is only for debugging purposes
and thus I felt free to use unsafePerformIO.
-}
counter :: IORef.IORef Int
counter =
   unsafePerformIO $ IORef.newIORef 0


assembleModule ::
   (llvmFunction -> EngineAccess externFunction) ->
   CodeGenModule llvmFunction ->
   IO externFunction
assembleModule comp bld = do
   m <- newModule
   (funcs, mappings) <-
      defineModule m (liftM2 (,) bld getGlobalMappings)

   -- write bitcode files for debugging
   num <- fmap (ListHT.padLeft '0' 3 . show) (IORef.readIORef counter)
   IORef.modifyIORef counter succ

   writeBitcodeToFile ("generator"++num++".bc") m

   optimizeModule 3 m

   writeBitcodeToFile ("generator"++num++"-opt.bc") m

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


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

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