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