@@ -13,7 +13,7 @@ import Util.System
1313import Numeric
1414import Data.Char
1515import Data.Bits
16−import Data.List (intercalate)
16+import Data.List (intercalate, nubBy)
1717import System.Process
1818import System.Exit
1919import System.IO
@@ -55,12 +55,13 @@ codegenC' :: [(Name, SDecl)] ->
5555codegenC' defs out exec incs objs libs flags exports iface dbg
5656 = do -- print defs
5757 let bc = map toBC defs
58+ let wrappers = genWrappers bc
5859 let h = concatMap toDecl (map fst bc)
5960 let cc = concatMap (uncurry toC) bc
6061 let hi = concatMap ifaceC (concatMap getExp exports)
6162 d <- getDataDir
6263 mprog <- readFile (d </> "rts" </> "idris_main" <.> "c")
63− let cout = headers incs ++ debug dbg ++ h ++ cc ++
64+ let cout = headers incs ++ debug dbg ++ h ++ wrappers ++ cc ++
6465 (if (exec == Executable) then mprog else hi)
6566 case exec of
6667 MavenProject -> putStrLn ("FAILURE: output type not supported")
@@ -317,6 +318,10 @@ bcc i (TOPBASE n) = indent i ++ "TOPBASE(" ++ show n ++ ");\n"
317318bcc i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n"
318319bcc i STOREOLD = indent i ++ "STOREOLD;\n"
319320bcc i (OP l fn args) = indent i ++ doOp (creg l ++ " = ") fn args ++ ";\n"
321+bcc i (FOREIGNCALL l rty (FStr fn) (x:xs)) | fn == "_idris_get_wrapper"
322+ = indent i ++
323+ c_irts (toFType rty) (creg l ++ " = ")
324+ (fn ++ "(" ++ creg (snd x) ++ ")") ++ ";\n"
320325bcc i (FOREIGNCALL l rty (FStr fn) args)
321326 = indent i ++
322327 c_irts (toFType rty) (creg l ++ " = ")
@@ -345,10 +350,18 @@ toFType (FCon c)
345350 | c == sUN "C_Unit" = FUnit
346351toFType (FApp c [_,ity])
347352 | c == sUN "C_IntT" = FArith (toAType ity)
353+ | c == sUN "C_FnT" = toFunType ity
348354toFType (FApp c [_])
349355 | c == sUN "C_Any" = FAny
350356toFType t = FAny
351357
358+toFunType (FApp c [_,ity])
359+ | c == sUN "C_FnBase" = FFunction
360+ | c == sUN "C_FnIO" = FFunctionIO
361+toFunType (FApp c [_,_,_,ity])
362+ | c == sUN "C_Fn" = toFunType ity
363+toFunType _ = FAny
364+
352365c_irts (FArith (ATInt ITNative)) l x = l ++ "MKINT((i_int)(" ++ x ++ "))"
353366c_irts (FArith (ATInt ITChar)) l x = c_irts (FArith (ATInt ITNative)) l x
354367c_irts (FArith (ATInt (ITFixed ity))) l x
@@ -359,6 +372,8 @@ c_irts FPtr l x = l ++ "MKPTR(vm, " ++ x ++ ")"
359372c_irts FManagedPtr l x = l ++ "MKMPTR(vm, " ++ x ++ ")"
360373c_irts (FArith ATFloat) l x = l ++ "MKFLOAT(vm, " ++ x ++ ")"
361374c_irts FAny l x = l ++ x
375+c_irts FFunction l x = error "Return of function from foreign call is not supported"
376+c_irts FFunctionIO l x = error "Return of function from foreign call is not supported"
362377
363378irts_c (FArith (ATInt ITNative)) x = "GETINT(" ++ x ++ ")"
364379irts_c (FArith (ATInt ITChar)) x = irts_c (FArith (ATInt ITNative)) x
@@ -370,6 +385,10 @@ irts_c FPtr x = "GETPTR(" ++ x ++ ")"
370385irts_c FManagedPtr x = "GETMPTR(" ++ x ++ ")"
371386irts_c (FArith ATFloat) x = "GETFLOAT(" ++ x ++ ")"
372387irts_c FAny x = x
388+irts_c FFunctionIO x = wrapped x
389+irts_c FFunction x = wrapped x
390+
391+wrapped x = "_idris_get_wrapper(" ++ x ++ ")"
373392
374393bitOp v op ty args = v ++ "idris_b" ++ show (nativeTyWidth ty) ++ op ++ "(vm, " ++ intercalate ", " (map creg args) ++ ")"
375394
@@ -713,3 +732,113 @@ hdr_export (ExportFun n cn ret args)
713732 showArgs ts
714733
715734 argNames = zipWith (++) (repeat "arg") (map show [0..])
735+
736+------------------ Callback wrapper generation ----------------
737+-- Generate callback wrappers and a function to select the
738+-- correct wrapper function to pass.
739+-- TODO: This is limited to functions that are specified in
740+-- the foreign call. Otherwise we would have to generate wrappers for all
741+-- functions with correct arity or do flow analysis
742+-- to find all possible inputs to the foreign call.
743+genWrappers :: [(Name, [BC])] -> String
744+genWrappers bcs = let
745+ tags = nubBy (\x y -> snd x == snd y) $ concatMap (getCallback . snd) bcs
746+ in
747+ case tags of
748+ [] -> ""
749+ t -> concatMap genWrapper t ++ genDispatcher t
750+
751+genDispatcher :: [(FDesc, Int)] -> String
752+genDispatcher tags = "void* _idris_get_wrapper(VAL con)\n" ++
753+ "{\n" ++
754+ indent 1 ++ "switch(TAG(con)) {\n" ++
755+ concatMap makeSwitch tags ++
756+ indent 1 ++ "}\n" ++
757+ indent 1 ++ "fprintf(stderr, \"No wrapper for callback\");\n" ++
758+ indent 1 ++ "exit(-1);\n" ++
759+ "}\n\n"
760+ where
761+ makeSwitch (_, tag) =
762+ indent 1 ++ "case " ++ show tag ++ ":\n" ++
763+ indent 2 ++ "return (void*) &" ++ wrapperName tag ++ ";\n"
764+
765+genWrapper :: (FDesc, Int) -> String
766+genWrapper (desc, tag) | (toFType desc) == FFunctionIO =
767+ error $ "Cannot create C callbacks for IO functions, wrap them with unsafePerformIO.\n"
768+genWrapper (desc, tag) = ret ++ " " ++ wrapperName tag ++ "(" ++
769+ renderArgs argList ++")\n" ++
770+ "{\n" ++
771+ (if ret /= "void" then indent 1 ++ ret ++ " ret;\n" else "") ++
772+ indent 1 ++ "VM* vm = get_vm();\n" ++
773+ indent 1 ++ "if (vm == NULL) {\n" ++
774+ indent 2 ++ "fprintf(stderr, \"No vm available in callback.\");\n" ++
775+ indent 2 ++ "exit(-1);\n" ++
776+ indent 1 ++ "}\n" ++
777+ indent 1 ++ "INITFRAME;\n" ++
778+ indent 1 ++ "RESERVE(" ++ show (len + 1) ++ ");\n" ++
779+ indent 1 ++ "allocCon(REG1, vm, " ++ show tag ++ ",0 , 0);\n" ++
780+ indent 1 ++ "TOP(0) = REG1;\n" ++
781+
782+ push 1 argList ++
783+ indent 1 ++ "STOREOLD;\n" ++
784+ indent 1 ++ "BASETOP(0);\n" ++
785+ indent 1 ++ "ADDTOP(" ++ show (len + 1) ++ ");\n" ++
786+ indent 1 ++ "CALL(_idris__123_APPLY0_125_);\n" ++
787+ if ret /= "void"
788+ then indent 1 ++ "ret = " ++ irts_c (toFType ft) "RVAL" ++ ";\n"
789+ ++ indent 1 ++ "return ret;\n}"
790+ else "}\n"
791+ where
792+ (ret, ft) = rty desc
793+ argList = zip (args desc) [0..]
794+ len = length argList
795+ renderArgs [] = "void"
796+ renderArgs [((s, _), n)] = s ++ " a" ++ (show n)
797+ renderArgs (((s, _), n):xs) = s ++ " a" ++ (show n) ++ ", " ++
798+ renderArgs xs
799+ rty (FApp c [_,ty])
800+ | c == sUN "C_FnBase" = (ctype ty, ty)
801+ | c == sUN "C_FnIO" = (ctype ty, ty)
802+ | c == sUN "C_FnT" = rty ty
803+ rty (FApp c [_,_,ty,fn])
804+ | c == sUN "C_Fn" = rty fn
805+ rty x = ("", x)
806+ args (FApp c [_,ty])
807+ | c == sUN "C_FnBase" = []
808+ | c == sUN "C_FnIO" = []
809+ | c == sUN "C_FnT" = args ty
810+ args (FApp c [_,_,ty,fn])
811+ | toFType ty == FUnit = []
812+ | c == sUN "C_Fn" = (ctype ty, ty) : args fn
813+ args _ = []
814+ push i [] = ""
815+ push i (((c, t), n) : ts) = indent 1 ++ c_irts (toFType t)
816+ ("TOP(" ++ show i ++ ") = ") ("a" ++ show n)
817+ ++ ";\n" ++ push (i + 1) ts
818+
819+wrapperName :: Int -> String
820+wrapperName tag = "_idris_wrapper_" ++ show tag
821+
822+getCallback :: [BC] -> [(FDesc, Int)]
823+getCallback bc = getCallback' (reverse bc)
824+ where
825+ getCallback' (x:xs) = case hasCallback x of
826+ [] -> getCallback' xs
827+ cbs -> case findCons cbs xs of
828+ [] -> error "Idris function couldn't be wrapped."
829+ x -> x
830+ getCallback' [] = []
831+ findCons (c:cs) xs = findCon c xs ++ findCons cs xs
832+ findCons [] _ = []
833+ findCon c ((MKCON l loc tag args):xs) | snd c == l = [(fst c, tag)]
834+ findCon c (_:xs) = findCon c xs
835+ findCon c [] = []
836+
837+hasCallback :: BC -> [(FDesc, Reg)]
838+hasCallback (FOREIGNCALL l rty (FStr fn) args) = filter isFn args
839+ where
840+ isFn (desc,_) = case toFType desc of
841+ FFunction -> True
842+ FFunctionIO -> True
843+ _ -> False
844+hasCallback _ = []