PoC calling dynamic C functions in Haskell

a.hs

{-# OPTIONS_GHC -ddump-simpl -ddump-stg -ddump-asm -ddump-cmm -ddump-opt-cmm -ddump-to-file #-}
{-# LANGUAGE GHCForeignImportPrim, UnliftedFFITypes, MagicHash, UnboxedTuples, RecursiveDo, GeneralizedNewtypeDeriving, BangPatterns #-}
module Main where

import Data.Coerce
import Foreign
import Foreign.C.String
import qualified System.Posix.DynamicLinker as DL
import qualified System.Posix.Signals as Sig
import qualified Control.Concurrent.Async as Async
import GHC.Exts (FunPtr(..), RealWorld, Addr#, Word(..), Word#, Int#, Ptr(..), addr2Int#, nullAddr#, Double#, Double(..), State#, int2Addr#)
import GHC.IO (IO(..))
import GHC.Int (Int(..), Int64(..))
import GHC.Word (Word64(..))
import Control.Concurrent (threadDelay)
import Control.Monad (forever)
import System.IO (hFlush, stdout)

foreign import ccall safe "dynamic"
    abs' :: FunPtr (Int -> IO Int) -> Int -> IO Int

--foreign import prim "cmm_test"
--    cmm_test :: Int# -> Int#

foreign import prim "manyargs"
    manyargs :: Int# -> Int# -> Int# -> Int# -> Int# -> Int# -> Int# -> Int# -> Int# -> Int# -> Int#

foreign import prim "reallyUnsafeCCaller"
    rUCC# :: Addr# -> Int# -> Int# -> Int# -> Int# -> Int# ->
                      Double# -> Double# -> Double# -> Double# -> Double# -> Double# ->
                      Int# -> Double# -> Double# -> Int# -> Addr# ->
                      State# RealWorld -> (# State# RealWorld, (# Int#, Double# #) #)

callFun :: FunPtr a -> Int64 -> Int64 -> Int64 -> Int64 -> Int64 ->
                       Double -> Double -> Double -> Double -> Double -> Double ->
                       Int64 -> Double -> Double -> Int -> Addr# -> IO (Int64, Double)
callFun (FunPtr addr) (I64# arg1) (I64# arg2) (I64# arg3) (I64# arg4) (I64# arg5)
                      (D# argF1) (D# argF2) (D# argF3) (D# argF4) (D# argF5) (D# argF6)
                      (I64# arg6) (D# argF7) (D# argF8) (I# bytesStack) stackAddr
--    = IO $ \s -> case rUCC# addr arg1 arg2 arg3 arg4 arg5 argF1 argF2 argF3 argF4 argF5 argF6 s of
    = IO $ \s -> case rUCC# addr arg1 arg2 arg3 arg4 arg5 argF1 argF2 argF3 argF4 argF5 argF6 arg6 argF7 argF8 bytesStack stackAddr s of
        (# s', (# res, resF #) #) -> (# s', (I64# res, D# resF) #)

loadSymbol :: String -> String -> IO (FunPtr a)
loadSymbol lib symbol = do
    libHandle <- DL.dlopen lib [DL.RTLD_LAZY]
    DL.dlsym libHandle symbol

type CRetType = Maybe CType
data CType = CInt | CFloat | CDouble | CPtr CRetType

passAsInt :: CType -> Bool
passAsInt a = case a of
    CInt -> True
    CPtr _ -> True
    CFloat -> False
    CDouble -> False

prepareArgs :: Num a => Int -> [a] -> [a]
prepareArgs limit l | length l == limit = l
                    | length l <  limit = take limit $ l ++ repeat 0
                    | length l >  limit = error "too many arguments"

class ToCRet a where
    toCRet :: (Int64, Double) -> a

instance ToCRet Int where
    toCRet (a, _) = fromIntegral a

instance ToCRet Double where
    toCRet (_, a) = a

instance ToCRet () where
    toCRet _ = ()

instance ToCRet (Ptr a) where
    toCRet ((I64# a),_) = Ptr (int2Addr# a)

callFunWrapper :: (Real floats, ToCRet a, Integral ints) => FunPtr dummy -> [ints] -> [floats] -> IO a
callFunWrapper funPtr ints floats = do
--    primRet <- callFun funPtr i1 i2 i3 i4 i5 d1 d2 d3 d4 d5 d6
    allocaBytesAligned 16 16 $ \(Ptr a) -> do
        poke (Ptr a) (1::Int64)
        poke ((Ptr a) `plusPtr` 8) (2::Int64)
        primRet <- callFun funPtr i1 i2 i3 i4 i5 d1 d2 d3 d4 d5 d6 i6 d7 d8 16 a
        return $ toCRet primRet
    where
        i1,i2,i3,i4,i5 :: Int64
        [i1,i2,i3,i4,i5,i6] = map fromIntegral $ prepareArgs 6 ints
        d1,d2,d3,d4,d5,d6 :: Double
        [d1,d2,d3,d4,d5,d6,d7,d8] = map realToFrac $ prepareArgs 8 floats

--defFun :: (Marshal b, Marshal c) => FunPtr a -> CRetType -> [CType] -> [b] -> c
--defFun funPtr retType argTypes = 
--    where
--        (intArgs, floatArgs) = partition passAsInt argTypes
--
--abs' <- defFun cFunPtr (Just CInt) [CInt]
--let foo = abs' [5]


ptr2Int :: Ptr a -> Int64
ptr2Int (Ptr addr) = I64# (addr2Int# addr)

data Ex = Ex Int Int Double deriving Show

instance Storable Ex where
    sizeOf _ = 16
    alignment _ = alignment (undefined :: Int)
    peek ptr = do
        Ex <$> (fmap fromIntegral $ peek (castPtr ptr :: Ptr Int32)) <*> peek (castPtr ptr `plusPtr` 4) <*> peek (castPtr ptr `plusPtr` 8)
    poke ptr (Ex i1 i2 d) = do
        poke (castPtr ptr :: Ptr Int32) (fromIntegral i1)
        poke (castPtr ptr `plusPtr` 4) i2
        poke (castPtr ptr `plusPtr` 8) d

newtype MagickWand = MagickWand (Ptr MagickWand) deriving ToCRet


dummy :: Int# -> Int# -> Int# -> Int# -> Int# -> Int# -> Int# -> Int# -> Int# -> Int# -> Int
dummy a _ _ _ _ _ _ _ _ _ = I# a
{-# NOINLINE dummy #-}

main = mdo
--    putStrLn (show $ I# (manyargs 1# 2# 3# 4# 5# 6# 7# 8# 9# 10#))
    --putStrLn (show $ cmm 666)
--    let !f = dummy 1# 2# 3# 4# 5# 6# 7# 8# 9# 10#
--    print f
--    libc <- DL.dlopen "libc.so.6" [DL.RTLD_LAZY]
--    libm <- DL.dlopen "libm.so.6" [DL.RTLD_LAZY]
--    absPtr <- DL.dlsym libc "abs"
--    let absFun = abs' absPtr
--    res <- absFun (666)
--    res2 <- callFunWrapper absPtr [-555] [] :: IO Int
--    --(res2, _) <- return $ callFun absPtr (-555) 0 0 0 0 0 0 0 0 0 0
--
--    fabs <- DL.dlsym libm "fabs"
--    res3 <- callFunWrapper fabs [] [(-555.0 :: Double)] :: IO Double
--    --putStrLn (show $ abs (-555.0))
--    putStrLn (show res3)
--    putStrLn (show $ length "huehuehue")
--    withCString "huehuehue" $ \ptr -> do
--        strlen <- DL.dlsym libc "strlen"
--        len <- callFunWrapper strlen [ptr2Int ptr] [] :: IO Int
--        putStrLn (show len)
--
    l <- DL.dlopen "l.so" [DL.RTLD_LAZY]
    foobar <- DL.dlsym l "foobar"

    res4 <- callFunWrapper foobar [1,2,3,4,5,6] [10.0,20.0,30.0,40.0,50.0,60.0,70.0,80.0] :: IO Int
    print res4
--
--    exInit <- DL.dlsym l "ex_init"
--    ex <- alloca $ \ptr -> do
--        callFunWrapper exInit [ptr2Int ptr] [] :: IO ()
--        peek ptr :: IO Ex
--    print ex
--
--    magick <- DL.dlopen "libMagickWand-7.Q16HDRI.so" [DL.RTLD_LAZY]
--    genesis <- DL.dlsym magick "MagickWandGenesis"
--    terminus <- DL.dlsym magick "MagickWandTerminus"
--    new <- DL.dlsym magick "NewMagickWand"
--    destroy <- DL.dlsym magick "DestroyMagickWand"
--    read <- DL.dlsym magick "MagickReadImage"
--    write <- DL.dlsym magick "MagickWriteImage"
--    resize <- DL.dlsym magick "MagickResizeImage"
--    getWidth <- DL.dlsym magick "MagickGetImageWidth"
--    getHeight <- DL.dlsym magick "MagickGetImageHeight"
--    setComp <- DL.dlsym magick "MagickSetImageCompressionQuality"
--
--    () <- callFunWrapper genesis [] []
--    wand <- callFunWrapper new [] [] :: IO MagickWand
--    () <- withCString "logo:" $ \logo -> callFunWrapper read [ptr2Int (coerce wand),ptr2Int logo] []
--    width <- callFunWrapper getWidth [ptr2Int (coerce wand)] [] :: IO Int
--    height <- callFunWrapper getHeight [ptr2Int (coerce wand)] [] :: IO Int
--
--    let newWidth = fromIntegral $ width `div` 2
--        newHeigth = fromIntegral $ height `div` 2
--
--    () <- callFunWrapper resize [ptr2Int (coerce wand), newWidth, newHeigth, 1] []
--    () <- callFunWrapper setComp [ptr2Int (coerce wand), 95] []
--    () <- withCString "logo.jpg" $ \file -> callFunWrapper write [ptr2Int (coerce wand), ptr2Int file] []
--    () <- callFunWrapper destroy [ptr2Int (coerce wand)] []
--    () <- callFunWrapper terminus [] []
--
--    putStrLn (show res)
    --putStrLn (show res2)
    --threadDelay 1000000
    return ()

l.c

#include <stdio.h>


typedef struct {
    int f1;
    int f2;
    double param;
} ex;

int foobar(int a1, int a2, int a3, int a4, int a5, int a6, char a7, char a8, double d1, double d2, double d3, double d4, double d5, double d6, double d7, double d8)
{
    printf("%d %d %d %d %d %d %d %d %f %f %f %f %f %f %f %f\n", a1, a2, a3, a4, a5, a6, (int)a7, (int)a8, d1, d2, d3, d4, d5, d6, d7, d8);
    return 666;
}

void ex_init(ex* p)
{
    printf("sizes: %lu %lu %lu %lu\n", sizeof p, sizeof(p->f1), sizeof(p->f2), sizeof(p->param));
    p->f1 = 666;
    p->f2 = 1024;
    p->param = -1.0;
}

wrapper.S

#define REG_Base  %r13
#define REG_Sp    %rbp
#define REG_Hp    %r12
#define REG_R1    %rbx
#define REG_R2    %r14
#define REG_R3    %rsi
#define REG_R4    %rdi
#define REG_R5    %r8
#define REG_R6    %r9
#define REG_SpLim %r15
#define REG_MachSp rsp

#define REG_D1 %xmm1
#define REG_D2 %xmm2
#define REG_D3 %xmm3
#define REG_D4 %xmm4
#define REG_D5 %xmm5
#define REG_D6 %xmm6

.macro returnHS
    jmp *(REG_Sp)
.endm

.global reallyUnsafeCCaller
reallyUnsafeCCaller:
    push %rbp
    push %r10
    push %r11
    push %r12
    push %r13
    push %r15
    push %rsp

    /* align stack to 16 bytes before call */
#   number of pushes above makes stack aligned to 16 bytes
#    and $-16, %rsp

    movq 24(%rbp), %rcx
    test %rcx, %rcx
    jz nostack

    # 24(%rbp) - number of bytes 
    # 32(%rbp) - pointer to pinned ByteArray# containing 
    #            arguments passed on stack

    movq 32(%rbp), %r10
copy:
    sub $8, %rcx
    movq (%r10, %rcx, 1), %rax
    push %rax
    test %rcx, %rcx
    jnz copy

nostack:
    mov REG_R4, %rdx
    mov REG_R2, %rdi
    /* mov REG_R3, %rsi noop */ 
    mov REG_R5, %rcx
    mov REG_R6, %r8
    mov (%rbp), %r9

    movsd REG_D1, %xmm0
    movsd REG_D2, %xmm1
    movsd REG_D3, %xmm2
    movsd REG_D4, %xmm3
    movsd REG_D5, %xmm4
    movsd REG_D6, %xmm5
    movsd 8(%rbp), %xmm6
    movsd 16(%rbp), %xmm7

    call *REG_R1
    add 24(%rbp), %rsp
    pop %rsp

    movsd %xmm0, REG_D1

    mov %rax, REG_R1
    
    pop %r15
    pop %r13
    pop %r12
    pop %r11
    pop %r10
    pop %rbp
    # unwind Haskell stack
    add $40, %rbp
    returnHS

.global manyargs
manyargs:
    returnHS