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