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