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