ref: 46e95ea2e5ff51c9b74c781843f03269b31c0779
dir: /ghc/PrimTable.hs/
module PrimTable(module PrimTable) where
import Control.Exception
import Data.Bits
import Data.Char
import Data.Maybe
import Data.Word()
import System.IO
import Unsafe.Coerce
import GHC.Types(Any)
import Foreign.C.String
import Foreign.C.Types
import Foreign.Marshal.Alloc
import Foreign.Ptr
import System.Environment
import System.IO.Unsafe
--import Debug.Trace
import Compat
type AnyType = Any
primitive :: String -> Any
--primitive s | trace ("primitive " ++ show s) False = undefined
primitive "dynsym" = unsafeCoerce dynsym
primitive s = fromMaybe (error $ "PrimTable.primitive: " ++ s) $ lookup s primOps
primOps :: [(String, Any)]
primOps =
[ comb "S" (\ f g x -> f x (g x))
, comb "K" (\ x _y -> x)
, comb "I" (\ x -> x)
, comb "B" (\ f g x -> f (g x))
, comb "C" (\ f g x -> f x g)
, comb "S'" (\ k f g x -> k (f x) (g x))
, comb "B'" (\ k f g x -> k f (g x))
, comb "C'" (\ k f g x -> k (f x) g)
, comb "A" (\ _x y -> y)
, comb "U" (\ x y -> y x)
, comb "Y" (\ f -> let r = f r in r)
, comb "Z" (\ f g _x -> f g)
, comb "P" (\ x y f -> f x y)
, comb "R" (\ x y f -> y f x)
, comb "O" (\ x y _g f -> f x y)
, comb "K2" (\ x _y _z -> x)
, comb "K3" (\ x _y _z _w -> x)
, comb "K4" (\ x _y _z _w _v -> x)
, comb "C'B" (\ x y z w -> x z (y w))
, arith "+" (+)
, arith "-" (-)
, arith "*" (*)
, arith "quot" quot
, arith "rem" rem
, arith "subtract" subtract
, arithu "neg" negate
, arithu "inv" complement
, arithw "uquot" quot
, arithw "urem" rem
, arithw "and" (.&.)
, arithw "or" (.|.)
, arithw "xor" xor
, arithwi "shl" shiftL
, arithwi "shr" shiftR
, arith "ashr" shiftR
, cmp "==" (==)
, cmp "/=" (/=)
, cmp "<" (<)
, cmp "<=" (<=)
, cmp ">" (>)
, cmp ">=" (>=)
, cmpw "u<" (<)
, cmpw "u<=" (<=)
, cmpw "u>" (>)
, cmpw "u>=" (>=)
, comb "icmp" (\ x y -> fromOrdering (compare (x::Int) y))
, comb "scmp" (\ x y -> fromOrdering (compare (toString x) (toString y)))
, comb "sequal" (\ x y -> fromBool (toString x == toString y))
, comb "p==" (\ x y -> fromBool ((x :: Ptr ()) == y))
, comb "pnull" nullPtr
, comb "pcast" castPtr
, comb "p+" plusPtr
, comb "p-" minusPtr
, farith "f+" (+)
, farith "f-" (-)
, farith "f*" (*)
, farith "f/" (/)
, farithu "fneg" negate
, fcmp "f==" (==)
, fcmp "f/=" (/=)
, fcmp "f<" (<)
, fcmp "f<=" (<=)
, fcmp "f>" (>)
, fcmp "f>=" (>=)
, comb "fshow" (fromString . (show :: Double -> String))
, comb "fread" ((read :: String -> Double) . toString)
, comb "itof" (fromIntegral :: Int -> Double)
, comb "seq" seq
, comb "rnf" rnf
, comb "error" err
, comb "ord" ord
, comb "chr" chr
, comb "IO.performIO" unsafePerformIO
, comb "IO.catch" (\ io hdl -> catch (io :: IO Any) (\ (exn :: SomeException) -> hdl (fromString $ takeWhile (/= '\n') $ show exn) :: IO Any))
, comb "IO.>>=" iobind
, comb "IO.>>" iothen
, comb "IO.return" ioret
, comb "IO.print" ioprint
, comb "IO.performio" unsafePerformIO
, comb "IO.serialize" ioserialize
, comb "IO.deserialize" iodeserialize
, comb "newCAStringLen" (fmap fromPair . newCAStringLen . toString)
, comb "IO.getArgs" iogetargs
, comb0 "IO.stdin" stdin
, comb0 "IO.stdout" stdout
, comb0 "IO.stderr" stderr
, comb "noMatch" (\ (s::Any) (l::Int) (c::Int) -> error ("no match at " ++ toString s ++ " line " ++ show l ++ ", col " ++ show c))
, comb "noDefault" (\ (s::Any) -> error ("no default for " ++ toString s))
]
where
comb0 n f = (n, unsafeCoerce f)
comb n f = (n, unsafeCoerce f)
-- comb n f = (n, unsafeCoerce (\ x -> trace (seq x n) (f x)))
arith :: String -> (Int -> Int -> Int) -> (String, Any)
arith = comb
arithw :: String -> (Word -> Word -> Word) -> (String, Any)
arithw = comb
arithwi :: String -> (Word -> Int -> Word) -> (String, Any)
arithwi = comb
arithu :: String -> (Int -> Int) -> (String, Any)
arithu = comb
farith :: String -> (Double -> Double -> Double) -> (String, Any)
farith = comb
farithu :: String -> (Double -> Double) -> (String, Any)
farithu = comb
cmp :: String -> (Int -> Int -> Bool) -> (String, Any)
cmp n f = comb n (\ x y -> fromBool (f x y))
cmpw :: String -> (Word -> Word -> Bool) -> (String, Any)
cmpw n f = comb n (\ x y -> fromBool (f x y))
fcmp :: String -> (Double -> Double -> Bool) -> (String, Any)
fcmp n f = comb n (\ x y -> fromBool (f x y))
err s = error $ "error: " ++ toString s
iobind :: IO a -> (a -> IO b) -> IO b
iobind = (>>=)
iothen :: IO a -> IO b -> IO b
iothen = (>>)
ioret :: a -> IO a
ioret = return
-- Can't implement this
ioprint :: Handle -> a -> IO ()
ioprint h _ = hPutStrLn h "no IO.print"
ioserialize :: Handle -> a -> IO ()
ioserialize h _ = hPutStrLn h "no IO.serialize"
iodeserialize :: Handle -> IO a
iodeserialize _ = error "iodeserialize"
iogetargs :: IO Any
iogetargs = do
args <- getArgs
return $ fromList $ map fromString args
-- Can't implement this
rnf :: a -> ()
rnf x = seq x ()
fromBool :: Bool -> Any
fromBool False = unsafeCoerce $ \ x _y -> x
fromBool True = unsafeCoerce $ \ _x y -> y
fromOrdering :: Ordering -> (Any -> Any -> Any -> Any)
fromOrdering LT = \ x _y _z -> x
fromOrdering EQ = \ _x y _z -> y
fromOrdering GT = \ _x _y z -> z
fromPair :: (a, b) -> Any
fromPair (x, y) = unsafeCoerce $ \ pair -> pair x y
fromString :: String -> Any
fromString = fromList . map (unsafeCoerce . ord)
fromList :: [Any] -> Any
fromList [] = unsafeCoerce $ \ nil _cons -> nil
fromList (x:xs) = unsafeCoerce $ \ _nil cons -> cons (unsafeCoerce x) (fromList xs)
toList :: Any -> [Int]
toList a = (unsafeCoerce a) [] (\ i is -> i : toList is)
toString :: Any -> String
toString = map chr . toList
dynsym :: Any -> Any
dynsym acfun =
let s = toString acfun
in
-- trace ("dynsym: " ++ show s) $
fromMaybe (error $ "cops: " ++ s) $ lookup s cops
cops :: [(String, Any)]
cops =
[ comb "fputc" fputc
, comb "getTimeMilli" getTimeMilli
, comb "fgetc" fgetc
, comb "fopen" fopen
, comb "fclose" fclose
, comb "free" free
, comb "exp" (fio exp)
, comb "log" (fio log)
, comb "sqrt" (fio sqrt)
, comb "sin" (fio sin)
, comb "cos" (fio cos)
, comb "tan" (fio tan)
, comb "asin" (fio asin)
, comb "acos" (fio acos)
, comb "atan" (fio atan)
, comb "sinh" (fio sinh)
, comb "cosh" (fio cosh)
, comb "tanh" (fio tanh)
, comb "asinh" (fio asinh)
, comb "acosh" (fio acosh)
, comb "atanh" (fio atanh)
, comb "atan2" (fio2 atan2)
]
where
comb n f = (n, unsafeCoerce f)
fio :: (Double -> Double) -> (Double -> IO Double)
fio f = return . f
fio2 :: (Double -> Double -> Double) -> (Double -> Double -> IO Double)
fio2 f = \ x y -> return (f x y)
fputc :: Int -> Handle -> IO Int
fputc c h = hPutChar h (chr c) >> return 0
fgetc :: Handle -> IO Int
fgetc h = handle (\ (_ :: SomeException) -> return (-1)) (do c <- hGetChar h; return (ord c))
fopen :: Ptr CChar -> Ptr CChar -> IO Handle
fopen name mode = do
sname <- peekCAString name
smode <- peekCAString mode
let hmode =
case smode of
"r" -> ReadMode
"w" -> WriteMode
"a" -> AppendMode
"w+" -> ReadWriteMode
_ -> error "fopen"
openFile sname hmode
fclose :: Handle -> IO Int
fclose h = do hClose h; return 0