ghc/lib/glaExts/Foreign.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1994-1996
   3 %
   4
   5 \section[Foreign]{Module @Foreign@}
   6
   7 \begin{code}
   8 {-# OPTIONS -fno-implicit-prelude #-}
   9
  10 module Foreign (
  11         module Foreign,
  12         ForeignObj(..),
  13         Addr(..), Word(..)
  14    ) where
  15
  16 import STBase
  17 -- import ArrBase
  18 import PrelBase
  19 import GHC
  20 \end{code}
  21
  22
  23 %*********************************************************
  24 %*                                                      *
  25 \subsection{Classes @CCallable@ and @CReturnable@}
  26 %*                                                      *
  27 %*********************************************************
  28
  29 \begin{code}
  30 class CCallable   a
  31 class CReturnable a
  32
  33 instance CCallable Char
  34 instance CCallable   Char#
  35 instance CReturnable Char
  36
  37 instance CCallable   Int
  38 instance CCallable   Int#
  39 instance CReturnable Int
  40
  41 -- DsCCall knows how to pass strings...
  42 instance CCallable   [Char]
  43
  44 instance CCallable   Float
  45 instance CCallable   Float#
  46 instance CReturnable Float
  47
  48 instance CCallable   Double
  49 instance CCallable   Double#
  50 instance CReturnable Double
  51
  52 data Addr = A# Addr#    deriving (Eq, Ord) -- Glasgow extension
  53
  54 instance CCallable Addr
  55 instance CCallable Addr#
  56 instance CReturnable Addr
  57
  58 data Word = W# Word#    deriving (Eq, Ord) -- Glasgow extension
  59
  60 instance CCallable Word
  61 instance CCallable Word#
  62 instance CReturnable Word
  63
  64 instance CReturnable () -- Why, exactly?
  65 \end{code}
  66
  67
  68 %*********************************************************
  69 %*                                                      *
  70 \subsection{Type @ForeignObj@ and its operations}
  71 %*                                                      *
  72 %*********************************************************
  73
  74 \begin{code}
  75 --Defined in PrelBase: data ForeignObj = ForeignObj ForeignObj#
  76 data ForeignObj = ForeignObj ForeignObj#   -- another one
  77
  78 instance CCallable ForeignObj
  79 instance CCallable ForeignObj#
  80
  81 eqForeignObj    :: ForeignObj  -> ForeignObj -> Bool
  82 makeForeignObj  :: Addr        -> Addr       -> PrimIO ForeignObj
  83 writeForeignObj :: ForeignObj  -> Addr       -> PrimIO ()
  84
  85 {- derived op - attaching a free() finaliser to a malloc() allocated reference. -}
  86 makeMallocPtr   :: Addr        -> PrimIO ForeignObj
  87
  88 makeForeignObj (A# obj) (A# finaliser) = ST ( \ (S# s#) ->
  89     case makeForeignObj# obj finaliser s# of
  90       StateAndForeignObj# s1# fo# -> (ForeignObj fo#, S# s1#))
  91
  92 writeForeignObj (ForeignObj fo#) (A# datum#) = ST ( \ (S# s#) ->
  93     case writeForeignObj# fo# datum# s# of { s1# -> ((), S# s1#) } )
  94
  95 makeMallocPtr a = makeForeignObj a (``&free''::Addr)
  96
  97 eqForeignObj mp1 mp2
  98   = unsafePerformPrimIO (_ccall_ eqForeignObj mp1 mp2) /= (0::Int)
  99
 100 instance Eq ForeignObj where
 101     p == q = eqForeignObj p q
 102     p /= q = not (eqForeignObj p q)
 103 \end{code}
 104
 105
 106 %*********************************************************
 107 %*                                                      *
 108 \subsection{Type @StablePtr@ and its operations}
 109 %*                                                      *
 110 %*********************************************************
 111
 112 \begin{code}
 113 #ifndef __PARALLEL_HASKELL__
 114 data StablePtr a = StablePtr (StablePtr# a)
 115 instance CCallable   (StablePtr a)
 116 instance CCallable   (StablePtr# a)
 117 instance CReturnable (StablePtr a)
 118
 119 -- Nota Bene: it is important {\em not\/} to inline calls to
 120 -- @makeStablePtr#@ since the corresponding macro is very long and we'll
 121 -- get terrible code-bloat.
 122
 123 makeStablePtr  :: a -> PrimIO (StablePtr a)
 124 deRefStablePtr :: StablePtr a -> PrimIO a
 125 freeStablePtr  :: StablePtr a -> PrimIO ()
 126 performGC      :: PrimIO ()
 127
 128 {-# INLINE deRefStablePtr #-}
 129 {-# INLINE freeStablePtr #-}
 130 {-# INLINE performGC #-}
 131
 132 makeStablePtr f = ST $ \ (S# rw1#) ->
 133     case makeStablePtr# f rw1# of
 134       StateAndStablePtr# rw2# sp# -> (StablePtr sp#, S# rw2#)
 135
 136 deRefStablePtr (StablePtr sp#) = ST $ \ (S# rw1#) ->
 137     case deRefStablePtr# sp# rw1# of
 138       StateAndPtr# rw2# a -> (a, S# rw2#)
 139
 140 freeStablePtr sp = _ccall_ freeStablePointer sp
 141
 142 performGC = _ccall_GC_ StgPerformGarbageCollection
 143
 144 #endif /* !__PARALLEL_HASKELL__ */
 145 \end{code}
 146
 147 %*********************************************************
 148 %*                                                      *
 149 \subsection{Ghastly return types}
 150 %*                                                      *
 151 %*********************************************************
 152
 153 \begin{code}
 154 #ifndef __PARALLEL_HASKELL__
 155 data StateAndStablePtr# s a = StateAndStablePtr# (State# s) (StablePtr# a)
 156 #endif
 157 data StateAndForeignObj# s  = StateAndForeignObj# (State# s) ForeignObj#
 158 \end{code}