git.iko.soy/Idris-dev
on db306ca help sign in
Idris-dev/src/Idris/Core/Execute.hs
586 lines 26 kB history raw
1{-# LANGUAGE PatternGuards, ExistentialQuantification, CPP #-}
2module Idris.Core.Execute (execute) where
4import Idris.AbsSyntax
5import Idris.AbsSyntaxTree
6import IRTS.Lang(FType(..))
8import Idris.Primitives(Prim(..), primitives)
10import Idris.Core.TT
11import Idris.Core.Evaluate
12import Idris.Core.CaseTree
14import Debug.Trace
16import Util.DynamicLinker
17import Util.System
19import Control.Applicative hiding (Const)
20import Control.Exception
21import Control.Monad.Trans
22import Control.Monad.Trans.State.Strict
23import Control.Monad.Trans.Error
24import Control.Monad
25import Data.Maybe
26import Data.Bits
27import qualified Data.Map as M
29#ifdef IDRIS_FFI
30import Foreign.LibFFI
31import Foreign.C.String
32import Foreign.Marshal.Alloc (free)
33import Foreign.Ptr
34#endif
36import System.IO
38#ifndef IDRIS_FFI
39execute :: Term -> Idris Term
40execute tm = fail "libffi not supported, rebuild Idris with -f FFI"
41#else
42-- else is rest of file
43readMay :: (Read a) => String -> Maybe a
44readMay s = case reads s of
45 [(x, "")] -> Just x
46 _ -> Nothing
48data Lazy = Delayed ExecEnv Context Term | Forced ExecVal deriving Show
50data ExecState = ExecState { exec_thunks :: M.Map Int Lazy -- ^ Thunks - the result of evaluating "lazy" or calling lazy funcs
51 , exec_next_thunk :: Int -- ^ Ensure thunk key uniqueness
52 , exec_implicits :: Ctxt [PArg] -- ^ Necessary info on laziness from idris monad
53 , exec_dynamic_libs :: [DynamicLib] -- ^ Dynamic libs from idris monad
54 }
56data ExecVal = EP NameType Name ExecVal
57 | EV Int
58 | EBind Name (Binder ExecVal) (ExecVal -> Exec ExecVal)
59 | EApp ExecVal ExecVal
60 | EType UExp
61 | EErased
62 | EConstant Const
63 | forall a. EPtr (Ptr a)
64 | EThunk Int
65 | EHandle Handle
67instance Show ExecVal where
68 show (EP _ n _) = show n
69 show (EV i) = "!!V" ++ show i ++ "!!"
70 show (EBind n b body) = "EBind " ++ show b ++ " <<fn>>"
71 show (EApp e1 e2) = show e1 ++ " (" ++ show e2 ++ ")"
72 show (EType _) = "Type"
73 show EErased = "[__]"
74 show (EConstant c) = show c
75 show (EPtr p) = "<<ptr " ++ show p ++ ">>"
76 show (EThunk i) = "<<thunk " ++ show i ++ ">>"
77 show (EHandle h) = "<<handle " ++ show h ++ ">>"
79toTT :: ExecVal -> Exec Term
80toTT (EP nt n ty) = (P nt n) <$> (toTT ty)
81toTT (EV i) = return $ V i
82toTT (EBind n b body) = do body' <- body $ EP Bound n EErased
83 b' <- fixBinder b
84 Bind n b' <$> toTT body'
85 where fixBinder (Lam t) = Lam <$> toTT t
86 fixBinder (Pi t) = Pi <$> toTT t
87 fixBinder (Let t1 t2) = Let <$> toTT t1 <*> toTT t2
88 fixBinder (NLet t1 t2) = NLet <$> toTT t1 <*> toTT t2
89 fixBinder (Hole t) = Hole <$> toTT t
90 fixBinder (GHole i t) = GHole i <$> toTT t
91 fixBinder (Guess t1 t2) = Guess <$> toTT t1 <*> toTT t2
92 fixBinder (PVar t) = PVar <$> toTT t
93 fixBinder (PVTy t) = PVTy <$> toTT t
94toTT (EApp e1 e2) = do e1' <- toTT e1
95 e2' <- toTT e2
96 return $ App e1' e2'
97toTT (EType u) = return $ TType u
98toTT EErased = return Erased
99toTT (EConstant c) = return (Constant c)
100toTT (EThunk i) = return (P (DCon 0 0) (sMN i "THUNK") Erased) --(force i) >>= toTT
101toTT (EHandle _) = return Erased
103unApplyV :: ExecVal -> (ExecVal, [ExecVal])
104unApplyV tm = ua [] tm
105 where ua args (EApp f a) = ua (a:args) f
106 ua args t = (t, args)
108mkEApp :: ExecVal -> [ExecVal] -> ExecVal
109mkEApp f [] = f
110mkEApp f (a:args) = mkEApp (EApp f a) args
112initState :: Idris ExecState
113initState = do ist <- getIState
114 return $ ExecState M.empty 0 (idris_implicits ist) (idris_dynamic_libs ist)
116type Exec = ErrorT String (StateT ExecState IO)
118runExec :: Exec a -> ExecState -> IO (Either String a)
119runExec ex st = fst <$> runStateT (runErrorT ex) st
121getExecState :: Exec ExecState
122getExecState = lift get
124putExecState :: ExecState -> Exec ()
125putExecState = lift . put
127execFail :: String -> Exec a
128execFail = throwError
130execIO :: IO a -> Exec a
131execIO = lift . lift
133delay :: ExecEnv -> Context -> Term -> Exec ExecVal
134delay env ctxt tm =
135 do st <- getExecState
136 let i = exec_next_thunk st
137 putExecState $ st { exec_thunks = M.insert i (Delayed env ctxt tm) (exec_thunks st)
138 , exec_next_thunk = exec_next_thunk st + 1
139 }
140 return $ EThunk i
142force :: Int -> Exec ExecVal
143force i = do st <- getExecState
144 case M.lookup i (exec_thunks st) of
145 Just (Delayed env ctxt tm) -> do tm' <- doExec env ctxt tm
146 case tm' of
147 EThunk i ->
148 do res <- force i
149 update res i
150 return res
151 _ -> do update tm' i
152 return tm'
153 Just (Forced tm) -> return tm
154 Nothing -> execFail "Tried to exec non-existing thunk. This is a bug!"
155 where update :: ExecVal -> Int -> Exec ()
156 update tm i = do est <- getExecState
157 putExecState $ est { exec_thunks = M.insert i (Forced tm) (exec_thunks est) }
159tryForce :: ExecVal -> Exec ExecVal
160tryForce (EThunk i) = force i
161tryForce tm = return tm
163debugThunks :: Exec ()
164debugThunks = do st <- getExecState
165 execIO $ putStrLn (take 4000 (show (exec_thunks st)))
167execute :: Term -> Idris Term
168execute tm = do est <- initState
169 ctxt <- getContext
170 res <- lift . lift $ flip runExec est $ do res <- doExec [] ctxt tm
171 toTT res
172 case res of
173 Left err -> fail err
174 Right tm' -> return tm'
176ioWrap :: ExecVal -> ExecVal
177ioWrap tm = mkEApp (EP (DCon 0 2) (sUN "prim__IO") EErased) [EErased, tm]
179ioUnit :: ExecVal
180ioUnit = ioWrap (EP Ref unitCon EErased)
182type ExecEnv = [(Name, ExecVal)]
184doExec :: ExecEnv -> Context -> Term -> Exec ExecVal
185doExec env ctxt p@(P Ref n ty) | Just v <- lookup n env = return v
186doExec env ctxt p@(P Ref n ty) =
187 do let val = lookupDef n ctxt
188 case val of
189 [Function _ tm] -> doExec env ctxt tm
190 [TyDecl _ _] -> return (EP Ref n EErased) -- abstract def
191 [Operator tp arity op] -> return (EP Ref n EErased) -- will be special-cased later
192 [CaseOp _ _ _ _ _ (CaseDefs _ ([], STerm tm) _ _)] -> -- nullary fun
193 doExec env ctxt tm
194 [CaseOp _ _ _ _ _ (CaseDefs _ (ns, sc) _ _)] -> return (EP Ref n EErased)
195 [] -> execFail $ "Could not find " ++ show n ++ " in definitions."
196 thing -> trace (take 200 $ "got to " ++ show thing ++ " lookup up " ++ show n) $ undefined
197doExec env ctxt p@(P Bound n ty) =
198 case lookup n env of
199 Nothing -> execFail "not found"
200 Just tm -> return tm
201doExec env ctxt (P (DCon a b) n _) = return (EP (DCon a b) n EErased)
202doExec env ctxt (P (TCon a b) n _) = return (EP (TCon a b) n EErased)
203doExec env ctxt v@(V i) | i < length env = return (snd (env !! i))
204 | otherwise = execFail "env too small"
205doExec env ctxt (Bind n (Let t v) body) = do v' <- doExec env ctxt v
206 doExec ((n, v'):env) ctxt body
207doExec env ctxt (Bind n (NLet t v) body) = trace "NLet" $ undefined
208doExec env ctxt tm@(Bind n b body) = return $
209 EBind n (fmap (\_->EErased) b)
210 (\arg -> doExec ((n, arg):env) ctxt body)
211doExec env ctxt a@(App _ _) = execApp env ctxt (unApply a)
212doExec env ctxt (Constant c) = return (EConstant c)
213doExec env ctxt (Proj tm i) = let (x, xs) = unApply tm in
214 doExec env ctxt ((x:xs) !! i)
215doExec env ctxt Erased = return EErased
216doExec env ctxt Impossible = fail "Tried to execute an impossible case"
217doExec env ctxt (TType u) = return (EType u)
219execApp :: ExecEnv -> Context -> (Term, [Term]) -> Exec ExecVal
220execApp env ctxt (f, args) = do newF <- doExec env ctxt f
221 laziness <- (++ repeat False) <$> (getLaziness newF)
222 newArgs <- mapM argExec (zip args laziness)
223 res <- execApp' env ctxt newF newArgs
224 return res
225 where getLaziness (EP _ l _) | l == sUN "lazy" = return [False, True]
226 getLaziness (EP _ n _) = do est <- getExecState
227 let argInfo = exec_implicits est
228 case lookupCtxtName n argInfo of
229 [] -> return (repeat False)
230 [ps] -> return $ map lazyarg (snd ps)
231 many -> execFail $ "Ambiguous " ++ show n ++ ", found " ++ (take 200 $ show many)
232 getLaziness _ = return (repeat False) -- ok due to zip above
233 argExec :: (Term, Bool) -> Exec ExecVal
234 argExec (tm, False) = doExec env ctxt tm
235 argExec (tm, True) = delay env ctxt tm
238execApp' :: ExecEnv -> Context -> ExecVal -> [ExecVal] -> Exec ExecVal
239execApp' env ctxt v [] = return v -- no args is just a constant! can result from function calls
240execApp' env ctxt (EP _ fp _) (ty:action:rest)
241 | fp == upio,
242 (prim__IO, [_, v]) <- unApplyV action
243 = execApp' env ctxt v rest
245execApp' env ctxt (EP _ fp _) args@(_:_:v:k:rest)
246 | fp == piobind,
247 (prim__IO, [_, v']) <- unApplyV v =
248 do v'' <- tryForce v'
249 res <- execApp' env ctxt k [v''] >>= tryForce
250 execApp' env ctxt res rest
251execApp' env ctxt con@(EP _ fp _) args@(tp:v:rest)
252 | fp == pioret =
253 do v' <- tryForce v
254 execApp' env ctxt (mkEApp con [tp, v']) rest
256-- Special cases arising from not having access to the C RTS in the interpreter
257execApp' env ctxt (EP _ fp _) (_:fn:EConstant (Str arg):_:rest)
258 | fp == mkfprim,
259 Just (FFun "putStr" _ _) <- foreignFromTT fn
260 = do execIO (putStr arg)
261 execApp' env ctxt ioUnit rest
262execApp' env ctxt (EP _ fp _) (_:fn:_:EHandle h:_:rest)
263 | fp == mkfprim,
264 Just (FFun "idris_readStr" _ _) <- foreignFromTT fn
265 = do contents <- execIO $ hGetLine h
266 execApp' env ctxt (EConstant (Str (contents ++ "\n"))) rest
267execApp' env ctxt (EP _ fp _) (_:fn:EConstant (Str f):EConstant (Str mode):rest)
268 | fp == mkfprim,
269 Just (FFun "fileOpen" _ _) <- foreignFromTT fn
270 = do f <- execIO $
271 catch (do let m = case mode of
272 "r" -> Right ReadMode
273 "w" -> Right WriteMode
274 "a" -> Right AppendMode
275 "rw" -> Right ReadWriteMode
276 "wr" -> Right ReadWriteMode
277 "r+" -> Right ReadWriteMode
278 _ -> Left ("Invalid mode for " ++ f ++ ": " ++ mode)
279 case fmap (openFile f) m of
280 Right h -> do h' <- h; return $ Right (ioWrap (EHandle h'), tail rest)
281 Left err -> return $ Left err)
282 (\e -> let _ = ( e::SomeException)
283 in return $ Right (ioWrap (EPtr nullPtr), tail rest))
284 case f of
285 Left err -> execFail err
286 Right (res, rest) -> execApp' env ctxt res rest
288execApp' env ctxt (EP _ fp _) (_:fn:(EHandle h):rest)
289 | fp == mkfprim,
290 Just (FFun "fileEOF" _ _) <- foreignFromTT fn
291 = do eofp <- execIO $ hIsEOF h
292 let res = ioWrap (EConstant (I $ if eofp then 1 else 0))
293 execApp' env ctxt res (tail rest)
295execApp' env ctxt (EP _ fp _) (_:fn:(EHandle h):rest)
296 | fp == mkfprim,
297 Just (FFun "fileClose" _ _) <- foreignFromTT fn
298 = do execIO $ hClose h
299 execApp' env ctxt ioUnit (tail rest)
301execApp' env ctxt (EP _ fp _) (_:fn:(EPtr p):rest)
302 | fp == mkfprim,
303 Just (FFun "isNull" _ _) <- foreignFromTT fn
304 = let res = ioWrap . EConstant . I $
305 if p == nullPtr then 1 else 0
306 in execApp' env ctxt res (tail rest)
308-- Handles will be checked as null pointers sometimes - but if we got a
309-- real Handle, then it's valid, so just return 1.
310execApp' env ctxt (EP _ fp _) (_:fn:(EHandle h):rest)
311 | fp == mkfprim,
312 Just (FFun "isNull" _ _) <- foreignFromTT fn
313 = let res = ioWrap . EConstant . I $ 0
314 in execApp' env ctxt res (tail rest)
316-- A foreign-returned char* has to be tested for NULL sometimes
317execApp' env ctxt (EP _ fp _) (_:fn:EConstant (Str s):rest)
318 | fp == mkfprim,
319 Just (FFun "isNull" _ _) <- foreignFromTT fn
320 = let res = ioWrap . EConstant . I $ 0
321 in execApp' env ctxt res (tail rest)
323-- Right now, there's no way to send command-line arguments to the executor,
324-- so just return 0.
325execApp' env ctxt (EP _ fp _) (_:fn:rest)
326 | fp == mkfprim,
327 Just (FFun "idris_numArgs" _ _) <- foreignFromTT fn
328 = let res = ioWrap . EConstant . I $ 0
329 in execApp' env ctxt res (tail rest)
330-- Throw away the 'World' argument to the foreign function
332execApp' env ctxt f@(EP _ fp _) args@(ty:fn:xs) | fp == mkfprim
333 = case foreignFromTT fn of
334 Just (FFun f argTs retT) | length xs >= length argTs ->
335 do let (args', xs') = (take (length argTs) xs, -- foreign args
336 drop (length argTs + 1) xs) -- rest
337 res <- stepForeign (ty:fn:args')
338 case res of
339 Nothing -> fail $ "Could not call foreign function \"" ++ f ++
340 "\" with args " ++ show args
341 Just r -> return (mkEApp r xs')
342 Nothing -> return (mkEApp f args)
344execApp' env ctxt c@(EP (DCon _ arity) n _) args =
345 do args' <- mapM tryForce (take arity args)
346 let restArgs = drop arity args
347 execApp' env ctxt (mkEApp c args') restArgs
349execApp' env ctxt c@(EP (TCon _ arity) n _) args =
350 do args' <- mapM tryForce (take arity args)
351 let restArgs = drop arity args
352 execApp' env ctxt (mkEApp c args') restArgs
354execApp' env ctxt f@(EP _ n _) args =
355 do let val = lookupDef n ctxt
356 case val of
357 [Function _ tm] -> fail "should already have been eval'd"
358 [TyDecl nt ty] -> return $ mkEApp f args
359 [Operator tp arity op] ->
360 if length args >= arity
361 then do args' <- mapM tryForce $ take arity args
362 case getOp n args' of
363 Just res -> do r <- res
364 execApp' env ctxt r (drop arity args)
365 Nothing -> return (mkEApp f args)
366 else return (mkEApp f args)
367 [CaseOp _ _ _ _ _ (CaseDefs _ ([], STerm tm) _ _)] -> -- nullary fun
368 do rhs <- doExec env ctxt tm
369 execApp' env ctxt rhs args
370 [CaseOp _ _ _ _ _ (CaseDefs _ (ns, sc) _ _)] ->
371 do res <- execCase env ctxt ns sc args
372 return $ fromMaybe (mkEApp f args) res
373 thing -> return $ mkEApp f args
374execApp' env ctxt bnd@(EBind n b body) (arg:args) = do ret <- body arg
375 let (f', as) = unApplyV ret
376 execApp' env ctxt f' (as ++ args)
377execApp' env ctxt (EThunk i) args = do f <- force i
378 execApp' env ctxt f args
379execApp' env ctxt app@(EApp _ _) args2 | (f, args1) <- unApplyV app = execApp' env ctxt f (args1 ++ args2)
380execApp' env ctxt f args = return (mkEApp f args)
382prs = sUN "prim__readString"
383pbm = sUN "prim__believe_me"
384pstd = sUN "prim__stdin"
385mkfprim = sUN "mkForeignPrim"
386pioret = sUN "prim_io_return"
387piobind = sUN "prim_io_bind"
388upio = sUN "unsafePerformPrimIO"
390-- | Look up primitive operations in the global table and transform them into ExecVal functions
391getOp :: Name -> [ExecVal] -> Maybe (Exec ExecVal)
392getOp fn [_, _, x] | fn == pbm = Just (return x)
393getOp fn [EP _ fn' _]
394 | fn == prs && fn' == pstd =
395 Just $ do line <- execIO getLine
396 return (EConstant (Str line))
397getOp fn [EHandle h]
398 | fn == prs =
399 Just $ do contents <- execIO $ hGetLine h
400 return (EConstant (Str (contents ++ "\n")))
401getOp n args = getPrim n primitives >>= flip applyPrim args
402 where getPrim :: Name -> [Prim] -> Maybe ([ExecVal] -> Maybe ExecVal)
403 getPrim n [] = Nothing
404 getPrim n ((Prim pn _ arity def _ _) : prims) | n == pn = Just $ execPrim def
405 | otherwise = getPrim n prims
407 execPrim :: ([Const] -> Maybe Const) -> [ExecVal] -> Maybe ExecVal
408 execPrim f args = EConstant <$> (mapM getConst args >>= f)
410 getConst (EConstant c) = Just c
411 getConst _ = Nothing
413 applyPrim :: ([ExecVal] -> Maybe ExecVal) -> [ExecVal] -> Maybe (Exec ExecVal)
414 applyPrim fn args = return <$> fn args
419-- | Overall wrapper for case tree execution. If there are enough arguments, it takes them,
420-- evaluates them, then begins the checks for matching cases.
421execCase :: ExecEnv -> Context -> [Name] -> SC -> [ExecVal] -> Exec (Maybe ExecVal)
422execCase env ctxt ns sc args =
423 let arity = length ns in
424 if arity <= length args
425 then do let amap = zip ns args
426-- trace ("Case " ++ show sc ++ "\n in " ++ show amap ++"\n in env " ++ show env ++ "\n\n" ) $ return ()
427 caseRes <- execCase' env ctxt amap sc
428 case caseRes of
429 Just res -> Just <$> execApp' (map (\(n, tm) -> (n, tm)) amap ++ env) ctxt res (drop arity args)
430 Nothing -> return Nothing
431 else return Nothing
433-- | Take bindings and a case tree and examines them, executing the matching case if possible.
434execCase' :: ExecEnv -> Context -> [(Name, ExecVal)] -> SC -> Exec (Maybe ExecVal)
435execCase' env ctxt amap (UnmatchedCase _) = return Nothing
436execCase' env ctxt amap (STerm tm) =
437 Just <$> doExec (map (\(n, v) -> (n, v)) amap ++ env) ctxt tm
438execCase' env ctxt amap (Case n alts) | Just tm <- lookup n amap =
439 do tm' <- tryForce tm
440 case chooseAlt tm' alts of
441 Just (newCase, newBindings) ->
442 let amap' = newBindings ++ (filter (\(x,_) -> not (elem x (map fst newBindings))) amap) in
443 execCase' env ctxt amap' newCase
444 Nothing -> return Nothing
446chooseAlt :: ExecVal -> [CaseAlt] -> Maybe (SC, [(Name, ExecVal)])
447chooseAlt _ (DefaultCase sc : alts) = Just (sc, [])
448chooseAlt (EConstant c) (ConstCase c' sc : alts) | c == c' = Just (sc, [])
449chooseAlt tm (ConCase n i ns sc : alts) | ((EP _ cn _), args) <- unApplyV tm
450 , cn == n = Just (sc, zip ns args)
451 | otherwise = chooseAlt tm alts
452chooseAlt tm (_:alts) = chooseAlt tm alts
453chooseAlt _ [] = Nothing
458idrisType :: FType -> ExecVal
459idrisType FUnit = EP Ref unitTy EErased
460idrisType ft = EConstant (idr ft)
461 where idr (FArith ty) = AType ty
462 idr FString = StrType
463 idr FPtr = PtrType
465data Foreign = FFun String [FType] FType deriving Show
468call :: Foreign -> [ExecVal] -> Exec (Maybe ExecVal)
469call (FFun name argTypes retType) args =
470 do fn <- findForeign name
471 maybe (return Nothing) (\f -> Just . ioWrap <$> call' f args retType) fn
472 where call' :: ForeignFun -> [ExecVal] -> FType -> Exec ExecVal
473 call' (Fun _ h) args (FArith (ATInt ITNative)) = do
474 res <- execIO $ callFFI h retCInt (prepArgs args)
475 return (EConstant (I (fromIntegral res)))
476 call' (Fun _ h) args (FArith (ATInt (ITFixed IT8))) = do
477 res <- execIO $ callFFI h retCChar (prepArgs args)
478 return (EConstant (B8 (fromIntegral res)))
479 call' (Fun _ h) args (FArith (ATInt (ITFixed IT16))) = do
480 res <- execIO $ callFFI h retCWchar (prepArgs args)
481 return (EConstant (B16 (fromIntegral res)))
482 call' (Fun _ h) args (FArith (ATInt (ITFixed IT32))) = do
483 res <- execIO $ callFFI h retCInt (prepArgs args)
484 return (EConstant (B32 (fromIntegral res)))
485 call' (Fun _ h) args (FArith (ATInt (ITFixed IT64))) = do
486 res <- execIO $ callFFI h retCLong (prepArgs args)
487 return (EConstant (B64 (fromIntegral res)))
488 call' (Fun _ h) args (FArith ATFloat) = do
489 res <- execIO $ callFFI h retCDouble (prepArgs args)
490 return (EConstant (Fl (realToFrac res)))
491 call' (Fun _ h) args (FArith (ATInt ITChar)) = do
492 res <- execIO $ callFFI h retCChar (prepArgs args)
493 return (EConstant (Ch (castCCharToChar res)))
494 call' (Fun _ h) args FString = do res <- execIO $ callFFI h retCString (prepArgs args)
495 if res == nullPtr
496 then return (EPtr res)
497 else do hStr <- execIO $ peekCString res
498 return (EConstant (Str hStr))
500 call' (Fun _ h) args FPtr = EPtr <$> (execIO $ callFFI h (retPtr retVoid) (prepArgs args))
501 call' (Fun _ h) args FUnit = do _ <- execIO $ callFFI h retVoid (prepArgs args)
502 return $ EP Ref unitCon EErased
503-- call' (Fun _ h) args other = fail ("Unsupported foreign return type " ++ show other)
506 prepArgs = map prepArg
507 prepArg (EConstant (I i)) = argCInt (fromIntegral i)
508 prepArg (EConstant (B8 i)) = argCChar (fromIntegral i)
509 prepArg (EConstant (B16 i)) = argCWchar (fromIntegral i)
510 prepArg (EConstant (B32 i)) = argCInt (fromIntegral i)
511 prepArg (EConstant (B64 i)) = argCLong (fromIntegral i)
512 prepArg (EConstant (Fl f)) = argCDouble (realToFrac f)
513 prepArg (EConstant (Ch c)) = argCChar (castCharToCChar c) -- FIXME - castCharToCChar only safe for first 256 chars
514 prepArg (EConstant (Str s)) = argString s
515 prepArg (EPtr p) = argPtr p
516 prepArg other = trace ("Could not use " ++ take 100 (show other) ++ " as FFI arg.") undefined
520foreignFromTT :: ExecVal -> Maybe Foreign
521foreignFromTT t = case (unApplyV t) of
522 (_, [(EConstant (Str name)), args, ret]) ->
523 do argTy <- unEList args
524 argFTy <- sequence $ map getFTy argTy
525 retFTy <- getFTy ret
526 return $ FFun name argFTy retFTy
527 _ -> trace ("failed to construct ffun") Nothing
529getFTy :: ExecVal -> Maybe FType
530getFTy (EApp (EP _ (UN fi) _) (EP _ (UN intTy) _))
531 | fi == txt "FIntT" =
532 case str intTy of
533 "ITNative" -> Just (FArith (ATInt ITNative))
534 "ITChar" -> Just (FArith (ATInt ITChar))
535 "IT8" -> Just (FArith (ATInt (ITFixed IT8)))
536 "IT16" -> Just (FArith (ATInt (ITFixed IT16)))
537 "IT32" -> Just (FArith (ATInt (ITFixed IT32)))
538 "IT64" -> Just (FArith (ATInt (ITFixed IT64)))
539 _ -> Nothing
540getFTy (EP _ (UN t) _) =
541 case str t of
542 "FFloat" -> Just (FArith ATFloat)
543 "FString" -> Just FString
544 "FPtr" -> Just FPtr
545 "FUnit" -> Just FUnit
546 _ -> Nothing
547getFTy _ = Nothing
549unEList :: ExecVal -> Maybe [ExecVal]
550unEList tm = case unApplyV tm of
551 (nil, [_]) -> Just []
552 (cons, ([_, x, xs])) ->
553 do rest <- unEList xs
554 return $ x:rest
555 (f, args) -> Nothing
558toConst :: Term -> Maybe Const
559toConst (Constant c) = Just c
560toConst _ = Nothing
562stepForeign :: [ExecVal] -> Exec (Maybe ExecVal)
563stepForeign (ty:fn:args) = let ffun = foreignFromTT fn
564 in case (call <$> ffun) of
565 Just f -> f args
566 Nothing -> return Nothing
567stepForeign _ = fail "Tried to call foreign function that wasn't mkForeignPrim"
569mapMaybeM :: (Functor m, Monad m) => (a -> m (Maybe b)) -> [a] -> m [b]
570mapMaybeM f [] = return []
571mapMaybeM f (x:xs) = do rest <- mapMaybeM f xs
572 maybe rest (:rest) <$> f x
573findForeign :: String -> Exec (Maybe ForeignFun)
574findForeign fn = do est <- getExecState
575 let libs = exec_dynamic_libs est
576 fns <- mapMaybeM getFn libs
577 case fns of
578 [f] -> return (Just f)
579 [] -> do execIO . putStrLn $ "Symbol \"" ++ fn ++ "\" not found"
580 return Nothing
581 fs -> do execIO . putStrLn $ "Symbol \"" ++ fn ++ "\" is ambiguous. Found " ++
582 show (length fs) ++ " occurrences."
583 return Nothing
584 where getFn lib = execIO $ catchIO (tryLoadFn fn lib) (\_ -> return Nothing)
586#endif