ghc/compiler/deSugar/DsCCall.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1994-1996
   3 %
   4 \section[DsCCall]{Desugaring \tr{_ccall_}s and \tr{_casm_}s}
   5
   6 \begin{code}
   7 module DsCCall
   8         (
   9            dsCCall
  10         ,  getIoOkDataCon
  11         ,  unboxArg
  12         ,  boxResult
  13         ,  can'tSeeDataConsPanic
  14         ) where
  15
  16 #include "HsVersions.h"
  17
  18 import CoreSyn
  19
  20 import DsMonad
  21 import DsUtils
  22
  23 import TcHsSyn          ( maybeBoxedPrimType )
  24 import CoreUtils        ( coreExprType )
  25 import Id               ( Id, dataConArgTys, idType )
  26 import Maybes           ( maybeToBool )
  27 import PrelVals         ( packStringForCId )
  28 import PrimOp           ( PrimOp(..) )
  29 import CallConv
  30 import Type             ( isUnpointedType, splitAlgTyConApp_maybe,
  31                           splitTyConApp_maybe, splitFunTys, splitForAllTys,
  32                           Type
  33                         )
  34 import TyCon            ( tyConDataCons )
  35 import TysPrim          ( byteArrayPrimTy, realWorldStatePrimTy,
  36                           byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
  37 import TysWiredIn       ( getStatePairingConInfo,
  38                           unitDataCon, stringTy,
  39                           realWorldStateTy, stateDataCon
  40                         )
  41 import Outputable
  42 \end{code}
  43
  44 Desugaring of @ccall@s consists of adding some state manipulation,
  45 unboxing any boxed primitive arguments and boxing the result if
  46 desired.
  47
  48 The state stuff just consists of adding in
  49 @PrimIO (\ s -> case s of { S# s# -> ... })@ in an appropriate place.
  50
  51 The unboxing is straightforward, as all information needed to unbox is
  52 available from the type.  For each boxed-primitive argument, we
  53 transform:
  54 \begin{verbatim}
  55    _ccall_ foo [ r, t1, ... tm ] e1 ... em
  56    |
  57    |
  58    V
  59    case e1 of { T1# x1# ->
  60    ...
  61    case em of { Tm# xm# -> xm#
  62    ccall# foo [ r, t1#, ... tm# ] x1# ... xm#
  63    } ... }
  64 \end{verbatim}
  65
  66 The reboxing of a @_ccall_@ result is a bit tricker: the types don't
  67 contain information about the state-pairing functions so we have to
  68 keep a list of \tr{(type, s-p-function)} pairs.  We transform as
  69 follows:
  70 \begin{verbatim}
  71    ccall# foo [ r, t1#, ... tm# ] e1# ... em#
  72    |
  73    |
  74    V
  75    \ s# -> case (ccall# foo [ r, t1#, ... tm# ] s# e1# ... em#) of
  76           (StateAnd<r># result# state#) -> (R# result#, realWorld#)
  77 \end{verbatim}
  78
  79 \begin{code}
  80 dsCCall :: FAST_STRING  -- C routine to invoke
  81         -> [CoreExpr]   -- Arguments (desugared)
  82         -> Bool         -- True <=> might cause Haskell GC
  83         -> Bool         -- True <=> really a "_casm_"
  84         -> Type         -- Type of the result (a boxed-prim IO type)
  85         -> DsM CoreExpr
  86
  87 dsCCall label args may_gc is_asm io_result_ty
  88   = newSysLocalDs realWorldStatePrimTy  `thenDs` \ old_s ->
  89
  90     mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) ->
  91     let
  92          final_args = Var old_s : unboxed_args
  93          (ioOkDataCon, _, result_ty) = getIoOkDataCon io_result_ty
  94     in
  95
  96     boxResult ioOkDataCon result_ty `thenDs` \ (final_result_ty, res_wrapper) ->
  97
  98     let
  99         the_ccall_op = CCallOp (Just label) is_asm may_gc cCallConv
 100                                (map coreExprType final_args)
 101                                final_result_ty
 102     in
 103     mkPrimDs the_ccall_op (map VarArg final_args) `thenDs` \ the_prim_app ->
 104     let
 105         the_body = foldr ($) (res_wrapper the_prim_app) arg_wrappers
 106     in
 107     returnDs (Lam (ValBinder old_s) the_body)
 108 \end{code}
 109
 110 \begin{code}
 111 unboxArg :: CoreExpr                    -- The supplied argument
 112          -> DsM (CoreExpr,              -- To pass as the actual argument
 113                  CoreExpr -> CoreExpr   -- Wrapper to unbox the arg
 114                 )
 115 unboxArg arg
 116
 117   -- Primitive types
 118   -- ADR Question: can this ever be used?  None of the PrimTypes are
 119   -- instances of the CCallable class.
 120   --
 121   -- SOF response:
 122   --    Oh yes they are, I've just added them :-) Having _ccall_ and _casm_
 123   --  that accept unboxed arguments is a Good Thing if you have a stub generator
 124   --  which generates the boiler-plate box-unbox code for you, i.e., it may help
 125   --  us nuke this very module :-)
 126   --
 127   | isUnpointedType arg_ty
 128   = returnDs (arg, \body -> body)
 129
 130   -- Strings
 131   | arg_ty == stringTy
 132   = newSysLocalDs byteArrayPrimTy               `thenDs` \ prim_arg ->
 133     mkAppDs (Var packStringForCId) [VarArg arg] `thenDs` \ pack_appn ->
 134     returnDs (Var prim_arg,
 135               \body -> Case pack_appn (PrimAlts []
 136                                                     (BindDefault prim_arg body))
 137     )
 138
 139   | null data_cons
 140     -- oops: we can't see the data constructors!!!
 141   = can'tSeeDataConsPanic "argument" arg_ty
 142
 143   -- Byte-arrays, both mutable and otherwise; hack warning
 144   | is_data_type &&
 145     length data_con_arg_tys == 2 &&
 146     maybeToBool maybe_arg2_tycon &&
 147     (arg2_tycon ==  byteArrayPrimTyCon ||
 148      arg2_tycon ==  mutableByteArrayPrimTyCon)
 149     -- and, of course, it is an instance of CCallable
 150   = newSysLocalsDs data_con_arg_tys             `thenDs` \ vars@[ixs_var, arr_cts_var] ->
 151     returnDs (Var arr_cts_var,
 152               \ body -> Case arg (AlgAlts [(the_data_con,vars,body)]
 153                                               NoDefault)
 154     )
 155
 156   -- Data types with a single constructor, which has a single, primitive-typed arg
 157   | maybeToBool maybe_boxed_prim_arg_ty
 158   = newSysLocalDs the_prim_arg_ty               `thenDs` \ prim_arg ->
 159     returnDs (Var prim_arg,
 160               \ body -> Case arg (AlgAlts [(box_data_con,[prim_arg],body)]
 161                                               NoDefault)
 162     )
 163
 164   | otherwise
 165   = getSrcLocDs `thenDs` \ l ->
 166     pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
 167   where
 168     arg_ty = coreExprType arg
 169
 170     maybe_boxed_prim_arg_ty = maybeBoxedPrimType arg_ty
 171     (Just (box_data_con, the_prim_arg_ty)) = maybe_boxed_prim_arg_ty
 172
 173     maybe_data_type                        = splitAlgTyConApp_maybe arg_ty
 174     is_data_type                           = maybeToBool maybe_data_type
 175     (Just (tycon, tycon_arg_tys, data_cons)) = maybe_data_type
 176     (the_data_con : other_data_cons)       = data_cons
 177
 178     data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys
 179     (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
 180
 181     maybe_arg2_tycon = splitTyConApp_maybe data_con_arg_ty2
 182     Just (arg2_tycon,_) = maybe_arg2_tycon
 183
 184 can'tSeeDataConsPanic thing ty
 185   = pprPanic "ERROR: Can't see the data constructor(s) for _ccall_/_casm_/foreign declaration"
 186              (hcat [text thing, text "; type: ", ppr ty, text "(try compiling with -fno-prune-tydecls ..)\n"])
 187 \end{code}
 188
 189
 190 \begin{code}
 191 boxResult :: Id                         -- IOok constructor
 192           -> Type                       -- Type of desired result
 193           -> DsM (Type,                 -- Type of the result of the ccall itself
 194                   CoreExpr -> CoreExpr) -- Wrapper for the ccall
 195                                         -- to box the result
 196 boxResult ioOkDataCon result_ty
 197   | null data_cons
 198   -- oops! can't see the data constructors
 199   = can'tSeeDataConsPanic "result" result_ty
 200
 201   -- Data types with a single constructor, which has a single, primitive-typed arg
 202   | (maybeToBool maybe_data_type) &&                            -- Data type
 203     (null other_data_cons) &&                                   -- Just one constr
 204     not (null data_con_arg_tys) && null other_args_tys  &&      -- Just one arg
 205     isUnpointedType the_prim_result_ty                          -- of primitive type
 206   =
 207     newSysLocalDs realWorldStatePrimTy          `thenDs` \ prim_state_id ->
 208     newSysLocalDs the_prim_result_ty            `thenDs` \ prim_result_id ->
 209
 210     mkConDs the_data_con (map TyArg tycon_arg_tys ++ [VarArg (Var prim_result_id)]) `thenDs` \ the_result ->
 211
 212     mkConDs ioOkDataCon
 213             [TyArg result_ty, VarArg (Var prim_state_id), VarArg the_result]
 214                                                         `thenDs` \ the_pair ->
 215     let
 216         the_alt = (state_and_prim_datacon, [prim_state_id, prim_result_id], the_pair)
 217     in
 218     returnDs (state_and_prim_ty,
 219               \prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
 220     )
 221
 222   -- Data types with a single nullary constructor
 223   | (maybeToBool maybe_data_type) &&                            -- Data type
 224     (null other_data_cons) &&                                   -- Just one constr
 225     (null data_con_arg_tys)
 226   =
 227     newSysLocalDs realWorldStatePrimTy          `thenDs` \ prim_state_id ->
 228
 229     mkConDs ioOkDataCon
 230             [TyArg result_ty, VarArg (Var prim_state_id), VarArg (Var unitDataCon)]
 231                                                 `thenDs` \ the_pair ->
 232
 233     let
 234         the_alt  = (stateDataCon, [prim_state_id], the_pair)
 235     in
 236     returnDs (realWorldStateTy,
 237               \prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
 238     )
 239
 240   | otherwise
 241   = pprPanic "boxResult: " (ppr result_ty)
 242
 243   where
 244     maybe_data_type                        = splitAlgTyConApp_maybe result_ty
 245     Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type
 246     (the_data_con : other_data_cons)       = data_cons
 247
 248     data_con_arg_tys                       = dataConArgTys the_data_con tycon_arg_tys
 249     (the_prim_result_ty : other_args_tys)  = data_con_arg_tys
 250
 251     (state_and_prim_datacon, state_and_prim_ty) = getStatePairingConInfo the_prim_result_ty
 252 \end{code}
 253
 254 This grimy bit of code is for digging out the IOok constructor from an
 255 application of the the IO type.  The constructor is needed for
 256 wrapping the result of a _ccall_.  The alternative is to wire-in IO,
 257 which brings a whole heap of junk with it.
 258
 259 If the representation of IO changes, this will probably have to be
 260 brought in line with the new definition.
 261
 262 newtype IO a = IO (State# RealWorld -> IOResult a)
 263
 264 the constructor IO has type (State# RealWorld -> IOResult a) -> IO a
 265
 266 \begin{code}
 267 getIoOkDataCon :: Type           -- IO t
 268                -> (Id, Id, Type) -- Returns (IOok, IO, t)
 269
 270 getIoOkDataCon io_ty
 271   = let
 272         Just (ioTyCon, [t])             = splitTyConApp_maybe io_ty
 273         [ioDataCon]                     = tyConDataCons ioTyCon
 274         ioDataConTy                     = idType ioDataCon
 275         (_, ioDataConTy')               = splitForAllTys ioDataConTy
 276         ([arg_ty], _)                   = splitFunTys ioDataConTy'
 277         (_, io_result_ty)               = splitFunTys arg_ty
 278         Just (io_result_tycon, _)       = splitTyConApp_maybe io_result_ty
 279         [ioOkDataCon,ioFailDataCon]     = tyConDataCons io_result_tycon
 280     in
 281     (ioOkDataCon, ioDataCon, t)
 282 \end{code}
 283
 284 Another way to do it, more sensitive:
 285
 286      case ioDataConTy of
 287         ForAll _ (FunTy (FunTy _ (AppTy (TyConTy ioResultTyCon _) _)) _) ->
 288                 let [ioOkDataCon,ioFailDataCon] = tyConDataCons ioResultTyCon
 289                 in
 290                 (ioOkDataCon, result_ty)
 291         _ -> pprPanic "getIoOkDataCon: " (ppr PprDebug ioDataConTy)