{-# LANGUAGE TypeSynonymInstances #-} module Grin.Eval.Primitives ( runExternal , listPrimitives , realWorld ) where import Grin.Types hiding (Value(..)) import qualified Grin.Types as Grin import qualified Data.Map as Map import CompactString import Grin.Types hiding (Value(..)) import Grin.Eval.Types import qualified Data.Map as Map import Control.Monad.State import Control.Exception import Foreign.Ptr import Foreign.Marshal.Alloc import Foreign.C import Foreign.Storable import Data.Char; import Data.Word; import Data.Bits; import Data.Int import Foreign.Marshal (copyBytes, newArray) import System.Posix (fdWrite,Fd(..)) import System.Posix.DynamicLinker import Foreign.LibFFI import Grin.Eval.Methods -- These functions are defined in the base library. I'm not sure how to deal with this properly. runExternal :: String -> [CompValue] -> Gen CompValue runExternal name args = do let returnIO v = return (Vector [realWorld, v]) return $ do args' <- mapM id args case (name, init args') of ("__hscore_memcpy_dst_off", [Lit (Lint dst),Lit (Lint off),Lit (Lint src),Lit (Lint size)]) -> do let dstPtr = nullPtr `plusPtr` fromIntegral (dst+off) srcPtr = nullPtr `plusPtr` fromIntegral src liftIO $ copyBytes dstPtr srcPtr (fromIntegral size) returnIO (Lit (Lint (dst+off))) ("__hscore_PrelHandle_write", [Lit (Lint fd),Lit (Lint ptr),Lit (Lint offset),Lit (Lint size)]) -> do let strPtr = nullPtr `plusPtr` fromIntegral (ptr+offset) str <- liftIO $ peekCStringLen (strPtr,fromIntegral size) out <- liftIO $ fdWrite (Fd (fromIntegral fd)) str returnIO (Lit (Lint $ fromIntegral out)) ("__hscore_get_errno", []) -> returnIO (Lit (Lint 0)) ("__hscore_bufsiz", []) -> returnIO (Lit (Lint 512)) ("fdReady", [fd,write,msecs,isSock]) -> returnIO (Lit (Lint 1)) ("getProgArgv", [Lit (Lint argcPtr), Lit (Lint argvPtr)]) -> do args <- getCommandArgs liftIO $ poke (nullPtr `plusPtr` fromIntegral argcPtr) (fromIntegral (length args) :: CInt) cs <- liftIO $ newArray =<< mapM newCString args liftIO $ poke (nullPtr `plusPtr` fromIntegral argvPtr) cs return $ Vector [Empty] (name, args) -> -- If we don't recognize the function, try loading it through the linker. do fnPtr <- liftIO $ dlsym Default name let toCArg (Lit (Lint i)) = argCInt (fromIntegral i) toCArg _ = error $ "Grin.Eval.Primitive.runExternal: Unrecognized argument type." ret <- liftIO $ callFFI fnPtr retCInt (map toCArg args) returnIO $ Lit (Lint (fromIntegral ret)) newtype IntArg = IntArg Int newtype CharArg = CharArg Char newtype ArrayArg = ArrayArg [EvalValue] newtype AnyArg = AnyArg EvalValue newtype PtrArg = PtrArg (Ptr ()) newtype HeapArg = HeapArg HeapPointer data RealWorld = RealWorld data Primitive = Primitive { primName :: String, primHandle :: ([EvalValue] -> CompExpression) } -- Primitive handlers listPrimitives :: GlobalScope -> [(Renamed, CompFunction)] listPrimitives globalScope = [ (Builtin name, primHandle (prim globalScope)) | (name, prim) <- Map.toList allPrimitives ] allPrimitives :: Map.Map CompactString (GlobalScope -> Primitive) allPrimitives = Map.fromList [ (fromString name, prim) | (name, prim) <- prims ] where prims = [ equal, gt, lt, gte, lte , chrPrim, ordPrim , plus, plusWord, minus, minusWord, times, timesWord, remInt, quotInt, addIntC , indexCharOffAddr , readInt32OffAddr, readInt8OffAddr, readAddrOffAddr , writeInt8OffAddr , writeCharArray , touch, makeStablePtr, writeStablePtrOffAddr , noDuplicate , realWorldPrim, myThreadIdPrim, raisePrim , catchPrim, blockAsyncExceptions, unblockAsyncExceptions , newPinnedByteArray, newAlignedPinnedByteArray , unsafeFreezeByteArray, byteArrayContents , updatePrim, fetchPrim, evalPrim, evalApplyPrim, applyPrim , newArrayPrim, readArray, writeArray , narrow8Word, narrow8Int, narrow16Word, narrow16Int, narrow32Int, negateInt , narrow32Word , mkWeak] -- Primitive definitions -- FIXME: Throw an error when values of different types are compared. equal = mkPrimitive "==#" $ binOp (==) gt = mkPrimitive ">#" $ binOp (>) lt = mkPrimitive "<#" $ binOp (<) gte = mkPrimitive ">=#" $ binOp (>=) lte = mkPrimitive "<=#" $ binOp (<=) plus = mkPrimitive "+#" $ binIntOp (+) plusWord = mkPrimitive "plusWord#" $ binIntOp (+) minus = mkPrimitive "-#" $ binIntOp (-) minusWord = mkPrimitive "minusWord#" $ binIntOp (-) times = mkPrimitive "*#" $ binIntOp (*) timesWord = mkPrimitive "timesWord#" $ binIntOp (*) remInt = mkPrimitive "remInt#" $ binIntOp rem quotInt = mkPrimitive "quotInt#" $ binIntOp quot chrPrim = mkPrimitive "chr#" $ return $ \(CharArg c) -> noScope $ return (Lit (Lchar c)) ordPrim = mkPrimitive "ord#" $ return $ \(IntArg i) -> noScope $ return (Lit (Lint $ fromIntegral i)) addIntC = mkPrimitive "addIntC#" $ return $ \(IntArg a) (IntArg b) -> let c = fromIntegral a + fromIntegral b o = c `shiftR` bitSize (0::Int) in noScope $ return (Vector [Lit (Lint c), Lit (Lint o)]) -- |Reads 8-bit character; offset in bytes. indexCharOffAddr = mkPrimitive "indexCharOffAddr#" $ return $ \(PtrArg ptr) (IntArg nth) -> noScope $ do c <- peekByteOff ptr nth :: IO Word8 return (Lit (Lchar (chr (fromIntegral (c::Word8))))) readInt32OffAddr = mkPrimitive "readInt32OffAddr#" $ return $ \(PtrArg ptr) (IntArg nth) RealWorld -> noScope $ do i <- peekElemOff (castPtr ptr) nth return (Vector [realWorld, fromInt (fromIntegral (i::Int32))]) readInt8OffAddr = mkPrimitive "readInt8OffAddr#" $ return $ \(PtrArg ptr) (IntArg nth) RealWorld -> noScope $ do i <- peekElemOff (castPtr ptr) nth return $ Vector [realWorld, fromInt (fromIntegral (i::Int8))] writeInt8OffAddr = mkPrimitive "writeInt8OffAddr#" $ return $ \(PtrArg ptr) (IntArg nth) (IntArg elt) RealWorld -> noScope $ do poke (ptr `plusPtr` nth) (fromIntegral elt :: Word8) return realWorld readAddrOffAddr = mkPrimitive "readAddrOffAddr#" $ return $ \(PtrArg ptr) (IntArg nth) RealWorld -> noScope $ do p <- peekElemOff (castPtr ptr) nth return $ Vector [realWorld, fromPointer p] -- |Write 8-bit character; offset in bytes. writeCharArray = mkPrimitive "writeCharArray#" $ return $ \(PtrArg ptr) (IntArg offset) (CharArg c) RealWorld -> noScope $ do poke (ptr `plusPtr` offset) (fromIntegral (ord c) :: Word8) return realWorld touch = mkPrimitive "touch#" $ return $ \(AnyArg _) RealWorld -> noScope $ return realWorld makeStablePtr = mkPrimitive "makeStablePtr#" $ return $ \(AnyArg a) RealWorld -> noScope $ return $ Vector [realWorld, Lit (Lstring "stable pointer")] writeStablePtrOffAddr = mkPrimitive "writeStablePtrOffAddr#" $ return $ \(PtrArg p) (IntArg n) (AnyArg stablePtr) RealWorld -> noScope $ return realWorld noDuplicate = mkPrimitive "noDuplicate#" $ return $ \RealWorld -> noScope $ return realWorld realWorldPrim = mkPrimitive "realWorld#" $ return $ noScope $ return realWorld myThreadIdPrim = mkPrimitive "myThreadId#" $ return $ \RealWorld -> noScope $ return (Vector [realWorld, Lit (Lint 0)]) raisePrim = mkPrimitive "raise#" $ return $ \(HeapArg ptr) -> do st <- get liftIO $ throwIO (GrinException st ptr) :: CompValue catchPrim = mkPrimitive "catch#" $ do evalApply <- lookupFunction (Builtin $ fromString "evalApply") apply <- lookupFunction (Builtin $ fromString "apply") return $ \(AnyArg fn) (AnyArg handler) RealWorld -> evalApply [fn, realWorld] {- `catchComp` \val -> do v <- evalApply [handler, val] apply [v, realWorld]-} blockAsyncExceptions = mkPrimitive "blockAsyncExceptions#" $ do apply <- lookupFunction (Builtin $ fromString "evalApply") return $ \(AnyArg fn) RealWorld -> apply [fn,realWorld] unblockAsyncExceptions = mkPrimitive "unblockAsyncExceptions#" $ do apply <- lookupFunction (Builtin $ fromString "evalApply") return $ \(AnyArg fn) RealWorld -> apply [fn, realWorld] -- |Create a mutable byte array that the GC guarantees not to move. newPinnedByteArray = mkPrimitive "newPinnedByteArray#" $ return $ \(IntArg size) RealWorld -> noScope $ do ptr <- mallocBytes size return (Vector [realWorld, fromPointer ptr]) newAlignedPinnedByteArray = mkPrimitive "newAlignedPinnedByteArray#" $ return $ \(IntArg size) (IntArg alignment) RealWorld -> noScope $ do ptr <- mallocBytes (size + alignment) return (Vector [realWorld, fromPointer $ alignPtr ptr alignment]) unsafeFreezeByteArray = mkPrimitive "unsafeFreezeByteArray#" $ return $ \(PtrArg ptr) RealWorld -> noScope $ return (Vector [realWorld, fromPointer ptr]) byteArrayContents = mkPrimitive "byteArrayContents#" $ return $ \(PtrArg ptr) -> noScope $ return (fromPointer ptr) updatePrim = mkPrimitive "update" $ return $ \(HeapArg ptr) (AnyArg val) -> do updateValue ptr val return Empty fetchPrim = mkPrimitive "fetch" $ return $ \(HeapArg ptr) -> do fetch ptr evalPrim = mkPrimitive "eval" $ return $ \(AnyArg arg) -> runEvalPrimitive arg evalApplyPrim = mkPrimitive "evalApply" $ return $ \(AnyArg fnPtr) (AnyArg arg) -> do fn <- runEvalPrimitive fnPtr case fn of FNode name fn 1 args -> fn (args ++ [arg]) FNode name fn 0 args -> error "apply: over application?" FNode name fn n args -> return $ FNode name fn (n-1) (args ++ [arg]) CNode name 0 args -> error "apply: over application?" CNode name n args -> return $ CNode name (n-1) (args ++ [arg]) _ -> error $ "weird apply: " ++ show fn applyPrim = mkPrimitive "apply" $ return $ \(AnyArg fn) (AnyArg arg) -> do case fn of FNode name fn 1 args -> fn (args ++ [arg]) FNode name fn 0 args -> error "apply: over application?" FNode name fn n args -> return $ FNode name fn (n-1) (args ++ [arg]) CNode name 0 args -> error "apply: over application?" CNode name n args -> return $ CNode name (n-1) (args ++ [arg]) _ -> error $ "weird apply: " ++ show fn newArrayPrim = mkPrimitive "newArray#" $ return $ \(IntArg len) (AnyArg elt) RealWorld -> do ptr <- storeValue (Array $ replicate len elt) return $ Vector [realWorld, HeapPointer ptr] readArray = mkPrimitive "readArray#" $ return $ \(HeapArg ptr) (IntArg idx) RealWorld -> do Array arr <- fetch ptr return $ Vector [realWorld, arr!!idx] writeArray = mkPrimitive "writeArray#" $ return $ \(HeapArg ptr) (IntArg idx) (AnyArg val) RealWorld -> do Array arr <- fetch ptr let (before,after) = splitAt idx arr updateValue ptr (Array (before ++ [val] ++ drop 1 after)) return realWorld -- |Create @MutVar\#@ with specified initial value in specified state thread. {- newMutVar = mkPrimitive "newMutVar#" $ return $ \(AnyArg val) RealWorld -> do ptr <- storeValue val return $ Vector [realWorld, HeapPointer ptr] -- |Write contents of @MutVar\#@. writeMutVar = mkPrimitive "writeMutVar#" $ return $ \(HeapArg ptr) (AnyArg val) RealWorld -> do updateValue ptr val return realWorld -- |Read contents of @MutVar\#@. Result is not yet evaluated. readMutVar = mkPrimitive "readMutVar#" $ return $ \(HeapArg ptr) RealWorld -> do val <- fetch ptr return (Vector [realWorld, val]) -} -- Dummy primitive mkWeak = mkPrimitive "mkWeak#" $ return $ \(AnyArg key) (AnyArg val) (AnyArg finalizer) RealWorld -> noScope $ return (Vector [realWorld, Empty]) fromInt32 i = fromInt (fromIntegral (fromIntegral i::Int32)::Int) fromWord32 i = fromInt (fromIntegral (fromIntegral i::Word32)::Int) fromInt16 i = fromInt (fromIntegral (fromIntegral i::Int16)::Int) fromWord16 i = fromInt (fromIntegral (fromIntegral i::Word16)::Int) fromInt8 i = fromInt (fromIntegral (fromIntegral i::Int8)::Int) fromWord8 i = fromInt (fromIntegral (fromIntegral i::Word8)::Int) narrow32Int = mkPrimitive "narrow32Int#" $ return $ \(IntArg i) -> noScope $ return (fromInt32 i) narrow32Word = mkPrimitive "narrow32Word#" $ return $ \(IntArg i) -> noScope $ return (fromWord32 i) narrow16Int = mkPrimitive "narrow16Int#" $ return $ \(IntArg i) -> noScope $ return (fromInt16 i) narrow16Word = mkPrimitive "narrow16Word#" $ return $ \(IntArg i) -> noScope $ return (fromWord16 i) narrow8Word = mkPrimitive "narrow8Word#" $ return $ \(IntArg i) -> noScope $ return (fromInt8 i) narrow8Int = mkPrimitive "narrow8Int#" $ return $ \(IntArg i) -> noScope $ return (fromWord8 i) negateInt = mkPrimitive "negateInt#" $ return $ \(IntArg i) -> noScope $ return (fromInt (negate i)) -- Primitive helpers noScope :: IO EvalValue -> CompValue noScope = liftIO runEvalPrimitive :: EvalValue -> CompValue runEvalPrimitive (HeapPointer ptr) = worker =<< fetch ptr where worker orig@(FNode name fn 0 args) = do --liftIO $ putStrLn $ "Running: " ++ show name ++ " " ++ show args reduced <- fn args updateValue ptr reduced return reduced worker val = return val runEvalPrimitive val = error $ "unhandled eval: " ++ show val fromPointer :: Ptr a -> EvalValue fromPointer ptr = Lit (Lint $ fromIntegral (minusPtr ptr nullPtr)) fromInt :: Int -> EvalValue fromInt = Lit . Lint . fromIntegral binOp :: (EvalValue -> EvalValue -> Bool) -> Gen (AnyArg -> AnyArg -> CompValue) binOp fn = do return $ \(AnyArg a) (AnyArg b) -> noScope $ if a `fn` b then return (Lit (Lint 1)) else return (Lit (Lint 0)) binIntOp :: (Int -> Int -> Int) -> Gen (IntArg -> IntArg -> CompValue) binIntOp fn = return $ \(IntArg a) (IntArg b) -> noScope $ return (Lit (Lint $ fromIntegral (fn a b))) realWorld :: EvalValue realWorld = Empty -- Mechanism for the primitives class IsPrimitive a where toPrimHandle :: String -> a -> [EvalValue] -> CompValue instance (IsPrimitive b, FromArg a) => IsPrimitive (a -> b) where toPrimHandle name fn (x:xs) = do val <- liftIO $ fromArg x toPrimHandle name (fn val) xs toPrimHandle name fn [] = error $ "Grin.Eval.Primitives.toPrimHandle: Not enough arguments for: " ++ name instance IsPrimitive (CompValue) where toPrimHandle name fn [] = fn toPrimHandle name fn _ = error $ "Grin.Eval.Primitives.toPrimHandle: Too many arguments to: " ++ name class FromArg a where fromArg :: EvalValue -> IO a instance FromArg AnyArg where fromArg = return . AnyArg instance FromArg RealWorld where fromArg Empty = return RealWorld fromArg v = error $ "Grin.Eval.Primitives.fromArg: Expected realWorld: " ++ show v instance FromArg IntArg where fromArg (Lit (Lint i)) = return (IntArg $ fromIntegral i) fromArg (Lit (Lchar c)) = return (IntArg $ ord c) fromArg v = error $ "Grin.Eval.Primitives.fromArg: Expected integer: " ++ show v instance FromArg CharArg where fromArg (Lit (Lchar c)) = return (CharArg c) fromArg (Lit (Lint i)) = return (CharArg (chr $ fromIntegral i)) fromArg v = error $ "Grin.Eval.Primitives.fromArg: Expected char: " ++ show v instance FromArg ArrayArg where fromArg (Array arr) = return (ArrayArg arr) fromArg v = error $ "Grin.Eval.Primitives.fromArg: Expected array: " ++ show v instance FromArg HeapArg where fromArg (HeapPointer ptr) = return (HeapArg ptr) fromArg v = error $ "Grin.Eval.Primitives.fromArg: Expected heap pointer: " ++ show v instance FromArg PtrArg where fromArg (Lit (Lstring str)) = do ptr <- liftIO $ newCString str return $ PtrArg (castPtr ptr) fromArg (Lit (Lint ptr)) = return $ PtrArg (nullPtr `plusPtr` fromIntegral ptr) fromArg v = error $ "Grin.Eval.Primitives.fromArg: Expected pointer: " ++ show v mkPrimitive :: IsPrimitive a => String -> Gen a -> (String, GlobalScope -> Primitive) mkPrimitive name fn = (name, \global -> Primitive { primName = name , primHandle = toPrimHandle name (fn global) })