git.iko.soy/Idris-dev
on 66ff954 help sign in
Idris-dev/src/Core/Execute.hs
567 lines 27 kB history raw
1{-# LANGUAGE PatternGuards, ExistentialQuantification #-}
2module Core.Execute (execute) where
4import Idris.AbsSyntax
5import Idris.AbsSyntaxTree
6import IRTS.Lang( IntTy(..)
7 , intTyToConst
8 , FType(..))
10import Core.TT
11import Core.Evaluate
12import Core.CaseTree
14import Debug.Trace
16import Util.DynamicLinker
17import Util.System
19import Control.Applicative hiding (Const)
20import Control.Monad.Trans
21import Control.Monad.Trans.State.Strict
22import Control.Monad.Trans.Error
23import Control.Monad
24import Data.Maybe
25import Data.Bits
26import qualified Data.Map as M
28import Foreign.LibFFI
29import Foreign.C.String
30import Foreign.Marshal.Alloc (free)
31import Foreign.Ptr
33import System.IO
36data Lazy = Delayed ExecEnv Context Term | Forced ExecVal deriving Show
38data ExecState = ExecState { exec_thunks :: M.Map Int Lazy -- ^ Thunks - the result of evaluating "lazy" or calling lazy funcs
39 , exec_next_thunk :: Int -- ^ Ensure thunk key uniqueness
40 , exec_implicits :: Ctxt [PArg] -- ^ Necessary info on laziness from idris monad
41 , exec_dynamic_libs :: [DynamicLib] -- ^ Dynamic libs from idris monad
42 }
44data ExecVal = EP NameType Name ExecVal
45 | EV Int
46 | EBind Name (Binder ExecVal) (ExecVal -> Exec ExecVal)
47 | EApp ExecVal ExecVal
48 | EType UExp
49 | EErased
50 | EConstant Const
51 | forall a. EPtr (Ptr a)
52 | EThunk Int
53 | EHandle Handle
55instance Show ExecVal where
56 show (EP _ n _) = show n
57 show (EV i) = "!!V" ++ show i ++ "!!"
58 show (EBind n b body) = "EBind " ++ show b ++ " <<fn>>"
59 show (EApp e1 e2) = show e1 ++ " (" ++ show e2 ++ ")"
60 show (EType _) = "Type"
61 show EErased = "[__]"
62 show (EConstant c) = show c
63 show (EPtr p) = "<<ptr " ++ show p ++ ">>"
64 show (EThunk i) = "<<thunk " ++ show i ++ ">>"
65 show (EHandle h) = "<<handle " ++ show h ++ ">>"
67toTT :: ExecVal -> Exec Term
68toTT (EP nt n ty) = (P nt n) <$> (toTT ty)
69toTT (EV i) = return $ V i
70toTT (EBind n b body) = do body' <- body $ EP Bound n EErased
71 b' <- fixBinder b
72 Bind n b' <$> toTT body'
73 where fixBinder (Lam t) = Lam <$> toTT t
74 fixBinder (Pi t) = Pi <$> toTT t
75 fixBinder (Let t1 t2) = Let <$> toTT t1 <*> toTT t2
76 fixBinder (NLet t1 t2) = NLet <$> toTT t1 <*> toTT t2
77 fixBinder (Hole t) = Hole <$> toTT t
78 fixBinder (GHole t) = GHole <$> toTT t
79 fixBinder (Guess t1 t2) = Guess <$> toTT t1 <*> toTT t2
80 fixBinder (PVar t) = PVar <$> toTT t
81 fixBinder (PVTy t) = PVTy <$> toTT t
82toTT (EApp e1 e2) = do e1' <- toTT e1
83 e2' <- toTT e2
84 return $ App e1' e2'
85toTT (EType u) = return $ TType u
86toTT EErased = return Erased
87toTT (EConstant c) = return (Constant c)
88toTT (EThunk i) = return (P (DCon 0 0) (MN i "THUNK") Erased) --(force i) >>= toTT
89toTT (EHandle _) = return Erased
91unApplyV :: ExecVal -> (ExecVal, [ExecVal])
92unApplyV tm = ua [] tm
93 where ua args (EApp f a) = ua (a:args) f
94 ua args t = (t, args)
96mkEApp :: ExecVal -> [ExecVal] -> ExecVal
97mkEApp f [] = f
98mkEApp f (a:args) = mkEApp (EApp f a) args
100initState :: Idris ExecState
101initState = do ist <- getIState
102 return $ ExecState M.empty 0 (idris_implicits ist) (idris_dynamic_libs ist)
104type Exec = ErrorT String (StateT ExecState IO)
106runExec :: Exec a -> ExecState -> IO (Either String a)
107runExec ex st = fst <$> runStateT (runErrorT ex) st
109getExecState :: Exec ExecState
110getExecState = lift get
112putExecState :: ExecState -> Exec ()
113putExecState = lift . put
115execFail :: String -> Exec a
116execFail = throwError
118execIO :: IO a -> Exec a
119execIO = lift . lift
121delay :: ExecEnv -> Context -> Term -> Exec ExecVal
122delay env ctxt tm =
123 do st <- getExecState
124 let i = exec_next_thunk st
125 putExecState $ st { exec_thunks = M.insert i (Delayed env ctxt tm) (exec_thunks st)
126 , exec_next_thunk = exec_next_thunk st + 1
127 }
128 return $ EThunk i
130force :: Int -> Exec ExecVal
131force i = do st <- getExecState
132 case M.lookup i (exec_thunks st) of
133 Just (Delayed env ctxt tm) -> do tm' <- doExec env ctxt tm
134 case tm' of
135 EThunk i ->
136 do res <- force i
137 update res i
138 return res
139 _ -> do update tm' i
140 return tm'
141 Just (Forced tm) -> return tm
142 Nothing -> execFail "Tried to exec non-existing thunk. This is a bug!"
143 where update :: ExecVal -> Int -> Exec ()
144 update tm i = do est <- getExecState
145 putExecState $ est { exec_thunks = M.insert i (Forced tm) (exec_thunks est) }
147tryForce :: ExecVal -> Exec ExecVal
148tryForce (EThunk i) = force i
149tryForce tm = return tm
151debugThunks :: Exec ()
152debugThunks = do st <- getExecState
153 execIO $ putStrLn (take 4000 (show (exec_thunks st)))
155execute :: Term -> Idris Term
156execute tm = do est <- initState
157 ctxt <- getContext
158 res <- lift $ flip runExec est $ do res <- doExec [] ctxt tm
159 toTT res
160 case res of
161 Left err -> fail err
162 Right tm' -> return tm'
164ioWrap :: ExecVal -> ExecVal
165ioWrap tm = mkEApp (EP (DCon 0 2) (UN "prim__IO") EErased) [EErased, tm]
167ioUnit :: ExecVal
168ioUnit = ioWrap (EP Ref unitCon EErased)
170type ExecEnv = [(Name, ExecVal)]
172doExec :: ExecEnv -> Context -> Term -> Exec ExecVal
173doExec env ctxt p@(P Ref n ty) | Just v <- lookup n env = return v
174doExec env ctxt p@(P Ref n ty) =
175 do let val = lookupDef n ctxt
176 case val of
177 [Function _ tm] -> doExec env ctxt tm
178 [TyDecl _ _] -> return (EP Ref n EErased) -- abstract def
179 [Operator tp arity op] -> return (EP Ref n EErased) -- will be special-cased later
180 [CaseOp _ _ _ _ _ [] (STerm tm) _ _] -> -- nullary fun
181 doExec env ctxt tm
182 [CaseOp _ _ _ _ _ ns sc _ _] -> return (EP Ref n EErased)
183 [] -> execFail $ "Could not find " ++ show n ++ " in definitions."
184 thing -> trace (take 200 $ "got to " ++ show thing ++ " lookup up " ++ show n) $ undefined
185doExec env ctxt p@(P Bound n ty) =
186 case lookup n env of
187 Nothing -> execFail "not found"
188 Just tm -> return tm
189doExec env ctxt (P (DCon a b) n _) = return (EP (DCon a b) n EErased)
190doExec env ctxt (P (TCon a b) n _) = return (EP (TCon a b) n EErased)
191doExec env ctxt v@(V i) | i < length env = return (snd (env !! i))
192 | otherwise = execFail "env too small"
193doExec env ctxt (Bind n (Let t v) body) = do v' <- doExec env ctxt v
194 doExec ((n, v'):env) ctxt body
195doExec env ctxt (Bind n (NLet t v) body) = trace "NLet" $ undefined
196doExec env ctxt tm@(Bind n b body) = return $
197 EBind n (fmap (\_->EErased) b)
198 (\arg -> doExec ((n, arg):env) ctxt body)
199doExec env ctxt a@(App _ _) = execApp env ctxt (unApply a)
200doExec env ctxt (Constant c) = return (EConstant c)
201doExec env ctxt (Proj tm i) = let (x, xs) = unApply tm in
202 doExec env ctxt ((x:xs) !! i)
203doExec env ctxt Erased = return EErased
204doExec env ctxt Impossible = fail "Tried to execute an impossible case"
205doExec env ctxt (TType u) = return (EType u)
207execApp :: ExecEnv -> Context -> (Term, [Term]) -> Exec ExecVal
208execApp env ctxt (f, args) = do newF <- doExec env ctxt f
209 laziness <- (++ repeat False) <$> (getLaziness newF)
210 newArgs <- mapM argExec (zip args laziness)
211 execApp' env ctxt newF newArgs
212 where getLaziness (EP _ (UN "lazy") _) = return [False, True]
213 getLaziness (EP _ n _) = do est <- getExecState
214 let argInfo = exec_implicits est
215 case lookupCtxtName n argInfo of
216 [] -> return (repeat False)
217 [ps] -> return $ map lazyarg (snd ps)
218 many -> execFail $ "Ambiguous " ++ show n ++ ", found " ++ (take 200 $ show many)
219 getLaziness _ = return (repeat False) -- ok due to zip above
220 argExec :: (Term, Bool) -> Exec ExecVal
221 argExec (tm, False) = doExec env ctxt tm
222 argExec (tm, True) = delay env ctxt tm
225execApp' :: ExecEnv -> Context -> ExecVal -> [ExecVal] -> Exec ExecVal
226execApp' env ctxt v [] = return v -- no args is just a constant! can result from function calls
227execApp' env ctxt (EP _ (UN "unsafePerformIO") _) (ty:action:rest) | (prim__IO, [_, v]) <- unApplyV action =
228 execApp' env ctxt v rest
230execApp' env ctxt (EP _ (UN "io_bind") _) args@(_:_:v:k:rest) | (prim__IO, [_, v']) <- unApplyV v =
231 do v'' <- tryForce v'
232 res <- execApp' env ctxt k [v''] >>= tryForce
233 execApp' env ctxt res rest
234execApp' env ctxt con@(EP _ (UN "io_return") _) args@(tp:v:rest) =
235 do v' <- tryForce v
236 execApp' env ctxt (mkEApp con [tp, v']) rest
238-- Special cases arising from not having access to the C RTS in the interpreter
239execApp' env ctxt (EP _ (UN "mkForeign") _) (_:fn:EConstant (Str arg):rest)
240 | Just (FFun "putStr" _ _) <- foreignFromTT fn = do execIO (putStr arg)
241 execApp' env ctxt ioUnit rest
242execApp' env ctxt (EP _ (UN "mkForeign") _) (_:fn:EConstant (Str f):EConstant (Str mode):rest)
243 | Just (FFun "fileOpen" _ _) <- foreignFromTT fn = do m <- case mode of
244 "r" -> return ReadMode
245 "w" -> return WriteMode
246 "a" -> return AppendMode
247 "rw" -> return ReadWriteMode
248 "wr" -> return ReadWriteMode
249 "r+" -> return ReadWriteMode
250 _ -> execFail ("Invalid mode for " ++ f ++ ": " ++ mode)
251 h <- execIO $ openFile f m
252 execApp' env ctxt (ioWrap (EHandle h)) rest
254execApp' env ctxt (EP _ (UN "mkForeign") _) (_:fn:(EHandle h):rest)
255 | Just (FFun "fileEOF" _ _) <- foreignFromTT fn = do eofp <- execIO $ hIsEOF h
256 let res = ioWrap (EConstant (I $ if eofp then 1 else 0))
257 execApp' env ctxt res rest
259execApp' env ctxt (EP _ (UN "mkForeign") _) (_:fn:(EHandle h):rest)
260 | Just (FFun "fileClose" _ _) <- foreignFromTT fn = do execIO $ hClose h
261 execApp' env ctxt ioUnit rest
263execApp' env ctxt (EP _ (UN "mkForeign") _) (_:fn:(EPtr p):rest)
264 | Just (FFun "isNull" _ _) <- foreignFromTT fn = let res = ioWrap . EConstant . I $
265 if p == nullPtr then 1 else 0
266 in execApp' env ctxt res rest
268execApp' env ctxt f@(EP _ (UN "mkForeign") _) args@(ty:fn:xs) | Just (FFun f argTs retT) <- foreignFromTT fn
269 , length xs >= length argTs =
270 do res <- stepForeign (ty:fn:take (length argTs) xs)
271 case res of
272 Nothing -> fail $ "Could not call foreign function \"" ++ f ++
273 "\" with args " ++ show (take (length argTs) xs)
274 Just r -> return (mkEApp r (drop (length argTs) xs))
275 | otherwise = return (mkEApp f args)
277execApp' env ctxt f@(EP _ n _) args =
278 do let val = lookupDef n ctxt
279 case val of
280 [Function _ tm] -> fail "should already have been eval'd"
281 [TyDecl nt ty] -> return $ mkEApp f args
282 [Operator tp arity op] ->
283 if length args >= arity
284 then do args' <- mapM tryForce $ take arity args
285 case getOp n args' of
286 Just res -> do r <- res
287 execApp' env ctxt r (drop arity args)
288 Nothing -> return (mkEApp f args)
289 else return (mkEApp f args)
290 [CaseOp _ _ _ _ _ [] (STerm tm) _ _] -> -- nullary fun
291 do rhs <- doExec env ctxt tm
292 execApp' env ctxt rhs args
293 [CaseOp _ _ _ _ _ ns sc _ _] ->
294 do res <- execCase env ctxt ns sc args
295 return $ fromMaybe (mkEApp f args) res
296 thing -> return $ mkEApp f args
297 where getOp :: Name -> [ExecVal] -> Maybe (Exec ExecVal)
298 getOp (UN "prim__addInt") [EConstant (I i1), EConstant (I i2)] =
299 primRes I (i1 + i2)
300 getOp (UN "prim__andInt") [EConstant (I i1), EConstant (I i2)] =
301 primRes I (i1 .&. i2)
302 getOp (UN "prim__charToInt") [EConstant (Ch c)] =
303 primRes I (fromEnum c)
304 getOp (UN "prim__complInt") [EConstant (I i)] =
305 primRes I (complement i)
306 getOp (UN "prim__concat") [EConstant (Str s1), EConstant (Str s2)] =
307 primRes Str (s1 ++ s2)
308 getOp (UN "prim__divInt") [EConstant (I i1), EConstant (I i2)] =
309 primRes I (i1 `div` i2)
310 getOp (UN "prim__eqChar") [EConstant (Ch c1), EConstant (Ch c2)] =
311 primResBool (c1 == c2)
312 getOp (UN "prim__eqInt") [EConstant (I i1), EConstant (I i2)] =
313 primResBool (i1 == i2)
314 getOp (UN "prim__eqString") [EConstant (Str s1), EConstant (Str s2)] =
315 primResBool (s1 == s2)
316 getOp (UN "prim__gtChar") [EConstant (Ch i1), EConstant (Ch i2)] =
317 primResBool (i1 > i2)
318 getOp (UN "prim__gteChar") [EConstant (Ch i1), EConstant (Ch i2)] =
319 primResBool (i1 >= i2)
320 getOp (UN "prim__gtInt") [EConstant (I i1), EConstant (I i2)] =
321 primResBool (i1 > i2)
322 getOp (UN "prim__gteInt") [EConstant (I i1), EConstant (I i2)] =
323 primResBool (i1 >= i2)
324 getOp (UN "prim__intToFloat") [EConstant (I i)] =
325 primRes Fl (fromRational (toRational i))
326 getOp (UN "prim__intToStr") [EConstant (I i)] =
327 primRes Str (show i)
328 getOp (UN "prim_lenString") [EConstant (Str s)] =
329 primRes I (length s)
330 getOp (UN "prim__ltChar") [EConstant (Ch i1), EConstant (Ch i2)] =
331 primResBool (i1 < i2)
332 getOp (UN "prim__lteChar") [EConstant (Ch i1), EConstant (Ch i2)] =
333 primResBool (i1 <= i2)
334 getOp (UN "prim__lteInt") [EConstant (I i1), EConstant (I i2)] =
335 primResBool (i1 <= i2)
336 getOp (UN "prim__ltInt") [EConstant (I i1), EConstant (I i2)] =
337 primResBool (i1 < i2)
338 getOp (UN "prim__modInt") [EConstant (I i1), EConstant (I i2)] =
339 primRes I (i1 `mod` i2)
340 getOp (UN "prim__mulBigInt") [EConstant (BI i1), EConstant (BI i2)] =
341 primRes BI (i1 * i2)
342 getOp (UN "prim__mulFloat") [EConstant (Fl i1), EConstant (Fl i2)] =
343 primRes Fl (i1 * i2)
344 getOp (UN "prim__mulInt") [EConstant (I i1), EConstant (I i2)] =
345 primRes I (i1 * i2)
346 getOp (UN "prim__orInt") [EConstant (I i1), EConstant (I i2)] =
347 primRes I (i1 .|. i2)
348 getOp (UN "prim__readString") [EP _ (UN "prim__stdin") _] =
349 Just $ do line <- execIO getLine
350 return (EConstant (Str line))
351 getOp (UN "prim__readString") [EHandle h] =
352 Just $ do contents <- execIO $ hGetLine h
353 return (EConstant (Str contents))
354 getOp (UN "prim__shLInt") [EConstant (I i1), EConstant (I i2)] =
355 primRes I (shiftL i1 i2)
356 getOp (UN "prim__shRInt") [EConstant (I i1), EConstant (I i2)] =
357 primRes I (shiftR i1 i2)
358 getOp (UN "prim__strCons") [EConstant (Ch c), EConstant (Str s)] =
359 primRes Str (c:s)
360 getOp (UN "prim__strHead") [EConstant (Str (c:s))] =
361 primRes Ch c
362 getOp (UN "prim__strRev") [EConstant (Str s)] =
363 primRes Str (reverse s)
364 getOp (UN "prim__strTail") [EConstant (Str (c:s))] =
365 primRes Str s
366 getOp (UN "prim__subFloat") [EConstant (Fl i1), EConstant (Fl i2)] =
367 primRes Fl (i1 - i2)
368 getOp (UN "prim__subInt") [EConstant (I i1), EConstant (I i2)] =
369 primRes I (i1 - i2)
370 getOp (UN "prim__xorInt") [EConstant (I i1), EConstant (I i2)] =
371 primRes I (i1 `xor` i2)
372 getOp n args = trace ("No prim " ++ show n ++ " for " ++ take 1000 (show args)) Nothing
374 primRes :: (a -> Const) -> a -> Maybe (Exec ExecVal)
375 primRes constr = Just . return . EConstant . constr
377 primResBool :: Bool -> Maybe (Exec ExecVal)
378 primResBool b = primRes I (if b then 1 else 0)
380execApp' env ctxt bnd@(EBind n b body) (arg:args) = do ret <- body arg
381 let (f', as) = unApplyV ret
382 execApp' env ctxt f' (as ++ args)
383execApp' env ctxt (EThunk i) args = do f <- force i
384 execApp' env ctxt f args
385execApp' env ctxt app@(EApp _ _) args2 | (f, args1) <- unApplyV app = execApp' env ctxt f (args1 ++ args2)
386execApp' env ctxt f args = return (mkEApp f args)
392-- | Overall wrapper for case tree execution. If there are enough arguments, it takes them,
393-- evaluates them, then begins the checks for matching cases.
394execCase :: ExecEnv -> Context -> [Name] -> SC -> [ExecVal] -> Exec (Maybe ExecVal)
395execCase env ctxt ns sc args =
396 let arity = length ns in
397 if arity <= length args
398 then do let amap = zip ns args
399-- trace ("Case " ++ show sc ++ "\n in " ++ show amap ++"\n in env " ++ show env ++ "\n\n" ) $ return ()
400 caseRes <- execCase' env ctxt amap sc
401 case caseRes of
402 Just res -> Just <$> execApp' (map (\(n, tm) -> (n, tm)) amap ++ env) ctxt res (drop arity args)
403 Nothing -> return Nothing
404 else return Nothing
406-- | Take bindings and a case tree and examines them, executing the matching case if possible.
407execCase' :: ExecEnv -> Context -> [(Name, ExecVal)] -> SC -> Exec (Maybe ExecVal)
408execCase' env ctxt amap (UnmatchedCase _) = return Nothing
409execCase' env ctxt amap (STerm tm) =
410 Just <$> doExec (map (\(n, v) -> (n, v)) amap ++ env) ctxt tm
411execCase' env ctxt amap (Case n alts) | Just tm <- lookup n amap =
412 do tm' <- tryForce tm
413 case chooseAlt tm' alts of
414 Just (newCase, newBindings) ->
415 let amap' = newBindings ++ (filter (\(x,_) -> not (elem x (map fst newBindings))) amap) in
416 execCase' env ctxt amap' newCase
417 Nothing -> return Nothing
419chooseAlt :: ExecVal -> [CaseAlt] -> Maybe (SC, [(Name, ExecVal)])
420chooseAlt _ (DefaultCase sc : alts) = Just (sc, [])
421chooseAlt (EConstant c) (ConstCase c' sc : alts) | c == c' = Just (sc, [])
422chooseAlt tm (ConCase n i ns sc : alts) | ((EP _ cn _), args) <- unApplyV tm
423 , cn == n = Just (sc, zip ns args)
424 | otherwise = chooseAlt tm alts
425chooseAlt tm (_:alts) = chooseAlt tm alts
426chooseAlt _ [] = Nothing
431idrisType :: FType -> ExecVal
432idrisType FUnit = EP Ref unitTy EErased
433idrisType ft = EConstant (idr ft)
434 where idr (FInt ty) = intTyToConst ty
435 idr FDouble = FlType
436 idr FChar = ChType
437 idr FString = StrType
438 idr FPtr = PtrType
440data Foreign = FFun String [FType] FType deriving Show
443call :: Foreign -> [ExecVal] -> Exec (Maybe ExecVal)
444call (FFun name argTypes retType) args =
445 do fn <- findForeign name
446 case fn of
447 Nothing -> return Nothing
448 Just f -> do res <- call' f args retType
449 return . Just . ioWrap $ res
450 where call' :: ForeignFun -> [ExecVal] -> FType -> Exec ExecVal
451 call' (Fun _ h) args (FInt ITNative) = do res <- execIO $ callFFI h retCInt (prepArgs args)
452 return (EConstant (I (fromIntegral res)))
453 call' (Fun _ h) args (FInt IT8) = do res <- execIO $ callFFI h retCChar (prepArgs args)
454 return (EConstant (B8 (fromIntegral res)))
455 call' (Fun _ h) args (FInt IT16) = do res <- execIO $ callFFI h retCWchar (prepArgs args)
456 return (EConstant (B16 (fromIntegral res)))
457 call' (Fun _ h) args (FInt IT32) = do res <- execIO $ callFFI h retCInt (prepArgs args)
458 return (EConstant (B32 (fromIntegral res)))
459 call' (Fun _ h) args (FInt IT64) = do res <- execIO $ callFFI h retCLong (prepArgs args)
460 return (EConstant (B64 (fromIntegral res)))
461 call' (Fun _ h) args FDouble = do res <- execIO $ callFFI h retCDouble (prepArgs args)
462 return (EConstant (Fl (realToFrac res)))
463 call' (Fun _ h) args FChar = do res <- execIO $ callFFI h retCChar (prepArgs args)
464 return (EConstant (Ch (castCCharToChar res)))
465 call' (Fun _ h) args FString = do res <- execIO $ callFFI h retCString (prepArgs args)
466 hStr <- execIO $ peekCString res
467-- lift $ free res
468 return (EConstant (Str hStr))
470 call' (Fun _ h) args FPtr = do res <- execIO $ callFFI h (retPtr retVoid) (prepArgs args)
471 return (EPtr res)
472 call' (Fun _ h) args FUnit = do res <- execIO $ callFFI h retVoid (prepArgs args)
473 return (EP Ref unitCon EErased)
474-- call' (Fun _ h) args other = fail ("Unsupported foreign return type " ++ show other)
477 prepArgs = map prepArg
478 prepArg (EConstant (I i)) = argCInt (fromIntegral i)
479 prepArg (EConstant (B8 i)) = argCChar (fromIntegral i)
480 prepArg (EConstant (B16 i)) = argCWchar (fromIntegral i)
481 prepArg (EConstant (B32 i)) = argCInt (fromIntegral i)
482 prepArg (EConstant (B64 i)) = argCLong (fromIntegral i)
483 prepArg (EConstant (Fl f)) = argCDouble (realToFrac f)
484 prepArg (EConstant (Ch c)) = argCChar (castCharToCChar c) -- FIXME - castCharToCChar only safe for first 256 chars
485 prepArg (EConstant (Str s)) = argString s
486 prepArg (EPtr p) = argPtr p
487 prepArg other = trace ("Could not use " ++ take 100 (show other) ++ " as FFI arg.") undefined
491foreignFromTT :: ExecVal -> Maybe Foreign
492foreignFromTT t = case (unApplyV t) of
493 (_, [(EConstant (Str name)), args, ret]) ->
494 do argTy <- unEList args
495 argFTy <- sequence $ map getFTy argTy
496 retFTy <- getFTy ret
497 return $ FFun name argFTy retFTy
498 _ -> trace "failed to construct ffun" Nothing
500getFTy :: ExecVal -> Maybe FType
501getFTy (EApp (EP _ (UN "FIntT") _) (EP _ (UN intTy) _)) =
502 case intTy of
503 "ITNative" -> Just $ FInt ITNative
504 "IT8" -> Just $ FInt IT8
505 "IT16" -> Just $ FInt IT16
506 "IT32" -> Just $ FInt IT32
507 "IT64" -> Just $ FInt IT64
508 _ -> Nothing
509getFTy (EP _ (UN t) _) =
510 case t of
511 "FFloat" -> Just FDouble
512 "FChar" -> Just FChar
513 "FString" -> Just FString
514 "FPtr" -> Just FPtr
515 "FUnit" -> Just FUnit
516 _ -> Nothing
517getFTy _ = Nothing
519unList :: Term -> Maybe [Term]
520unList tm = case unApply tm of
521 (nil, [_]) -> Just []
522 (cons, ([_, x, xs])) ->
523 do rest <- unList xs
524 return $ x:rest
525 (f, args) -> Nothing
527unEList :: ExecVal -> Maybe [ExecVal]
528unEList tm = case unApplyV tm of
529 (nil, [_]) -> Just []
530 (cons, ([_, x, xs])) ->
531 do rest <- unEList xs
532 return $ x:rest
533 (f, args) -> Nothing
536toConst :: Term -> Maybe Const
537toConst (Constant c) = Just c
538toConst _ = Nothing
540stepForeign :: [ExecVal] -> Exec (Maybe ExecVal)
541stepForeign (ty:fn:args) = do let ffun = foreignFromTT fn
542 f' <- case (call <$> ffun) of
543 Just f -> f args
544 Nothing -> return Nothing
545 return f'
546stepForeign _ = fail "Tried to call foreign function that wasn't mkForeign"
548mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]
549mapMaybeM f [] = return []
550mapMaybeM f (x:xs) = do rest <- mapMaybeM f xs
551 x' <- f x
552 case x' of
553 Just x'' -> return (x'':rest)
554 Nothing -> return rest
556findForeign :: String -> Exec (Maybe ForeignFun)
557findForeign fn = do est <- getExecState
558 let libs = exec_dynamic_libs est
559 fns <- mapMaybeM getFn libs
560 case fns of
561 [f] -> return (Just f)
562 [] -> do execIO . putStrLn $ "Symbol \"" ++ fn ++ "\" not found"
563 return Nothing
564 fs -> do execIO . putStrLn $ "Symbol \"" ++ fn ++ "\" is ambiguous. Found " ++
565 show (length fs) ++ " occurrences."
566 return Nothing
567 where getFn lib = execIO $ catchIO (tryLoadFn fn lib) (\_ -> return Nothing)