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 )
  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) )
  29 import TysPrim          ( byteArrayPrimTy, realWorldTy,  realWorldStatePrimTy,
  30                           byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
  31 import TysWiredIn       ( getStatePairingConInfo,
  32                           stRetDataCon, pairDataCon, unitDataCon,
  33                           stringTy,
  34                           realWorldStateTy, stateDataCon
  35                         )
  36 import Util             ( pprPanic, pprError, panic )
  37
  38 \end{code}
  39
  40 Desugaring of @ccall@s consists of adding some state manipulation,
  41 unboxing any boxed primitive arguments and boxing the result if
  42 desired.
  43
  44 The state stuff just consists of adding in
  45 @PrimIO (\ s -> case s of { S# s# -> ... })@ in an appropriate place.
  46
  47 The unboxing is straightforward, as all information needed to unbox is
  48 available from the type.  For each boxed-primitive argument, we
  49 transform:
  50 \begin{verbatim}
  51    _ccall_ foo [ r, t1, ... tm ] e1 ... em
  52    |
  53    |
  54    V
  55    case e1 of { T1# x1# ->
  56    ...
  57    case em of { Tm# xm# -> xm#
  58    ccall# foo [ r, t1#, ... tm# ] x1# ... xm#
  59    } ... }
  60 \end{verbatim}
  61
  62 The reboxing of a @_ccall_@ result is a bit tricker: the types don't
  63 contain information about the state-pairing functions so we have to
  64 keep a list of \tr{(type, s-p-function)} pairs.  We transform as
  65 follows:
  66 \begin{verbatim}
  67    ccall# foo [ r, t1#, ... tm# ] e1# ... em#
  68    |
  69    |
  70    V
  71    \ s# -> case (ccall# foo [ r, t1#, ... tm# ] s# e1# ... em#) of
  72           (StateAnd<r># result# state#) -> (R# result#, realWorld#)
  73 \end{verbatim}
  74
  75 \begin{code}
  76 dsCCall :: FAST_STRING  -- C routine to invoke
  77         -> [CoreExpr]   -- Arguments (desugared)
  78         -> Bool         -- True <=> might cause Haskell GC
  79         -> Bool         -- True <=> really a "_casm_"
  80         -> Type         -- Type of the result (a boxed-prim type)
  81         -> DsM CoreExpr
  82
  83 dsCCall label args may_gc is_asm result_ty
  84   = newSysLocalDs realWorldStatePrimTy  `thenDs` \ old_s ->
  85
  86     mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) ->
  87     let
  88          final_args = Var old_s : unboxed_args
  89     in
  90
  91     boxResult result_ty         `thenDs` \ (final_result_ty, res_wrapper) ->
  92
  93     let
  94         the_ccall_op = CCallOp label is_asm may_gc
  95                                (map coreExprType final_args)
  96                                final_result_ty
  97     in
  98     mkPrimDs the_ccall_op (map VarArg final_args) `thenDs` \ the_prim_app ->
  99     let
 100         the_body = foldr ($) (res_wrapper the_prim_app) arg_wrappers
 101     in
 102     returnDs (Lam (ValBinder old_s) the_body)
 103 \end{code}
 104
 105 \begin{code}
 106 unboxArg :: CoreExpr                    -- The supplied argument
 107          -> DsM (CoreExpr,              -- To pass as the actual argument
 108                  CoreExpr -> CoreExpr   -- Wrapper to unbox the arg
 109                 )
 110 unboxArg arg
 111
 112   -- Primitive types
 113   -- ADR Question: can this ever be used?  None of the PrimTypes are
 114   -- instances of the CCallable class.
 115   --
 116   -- SOF response:
 117   --    Oh yes they are, I've just added them :-) Having _ccall_ and _casm_
 118   --  that accept unboxed arguments is a Good Thing if you have a stub generator
 119   --  which generates the boiler-plate box-unbox code for you, i.e., it may help
 120   --  us nuke this very module :-)
 121   --
 122   | isPrimType arg_ty
 123   = returnDs (arg, \body -> body)
 124
 125   -- Strings
 126   | arg_ty `eqTy` stringTy
 127   -- ToDo (ADR): - allow synonyms of Strings too?
 128   = newSysLocalDs byteArrayPrimTy               `thenDs` \ prim_arg ->
 129     mkAppDs (Var packStringForCId) [VarArg arg] `thenDs` \ pack_appn ->
 130     returnDs (Var prim_arg,
 131               \body -> Case pack_appn (PrimAlts []
 132                                                     (BindDefault prim_arg body))
 133     )
 134
 135   | null data_cons
 136     -- oops: we can't see the data constructors!!!
 137   = can't_see_datacons_error "argument" arg_ty
 138
 139   -- Byte-arrays, both mutable and otherwise; hack warning
 140   | is_data_type &&
 141     length data_con_arg_tys == 2 &&
 142     maybeToBool maybe_arg2_tycon &&
 143     (arg2_tycon ==  byteArrayPrimTyCon ||
 144      arg2_tycon ==  mutableByteArrayPrimTyCon)
 145     -- and, of course, it is an instance of CCallable
 146   = newSysLocalsDs data_con_arg_tys             `thenDs` \ vars@[ixs_var, arr_cts_var] ->
 147     returnDs (Var arr_cts_var,
 148               \ body -> Case arg (AlgAlts [(the_data_con,vars,body)]
 149                                               NoDefault)
 150     )
 151
 152   -- Data types with a single constructor, which has a single, primitive-typed arg
 153   | maybeToBool maybe_boxed_prim_arg_ty
 154   = newSysLocalDs the_prim_arg_ty               `thenDs` \ prim_arg ->
 155     returnDs (Var prim_arg,
 156               \ body -> Case arg (AlgAlts [(box_data_con,[prim_arg],body)]
 157                                               NoDefault)
 158     )
 159
 160   | otherwise
 161   = pprPanic "unboxArg: " (ppr PprDebug arg_ty)
 162   where
 163     arg_ty = coreExprType arg
 164
 165     maybe_boxed_prim_arg_ty = maybeBoxedPrimType arg_ty
 166     (Just (box_data_con, the_prim_arg_ty)) = maybe_boxed_prim_arg_ty
 167
 168     maybe_data_type                        = maybeAppDataTyConExpandingDicts arg_ty
 169     is_data_type                           = maybeToBool maybe_data_type
 170     (Just (tycon, tycon_arg_tys, data_cons)) = maybe_data_type
 171     (the_data_con : other_data_cons)       = data_cons
 172
 173     data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys
 174     (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
 175
 176     maybe_arg2_tycon = maybeAppTyCon data_con_arg_ty2
 177     Just (arg2_tycon,_) = maybe_arg2_tycon
 178
 179 can't_see_datacons_error thing ty
 180   = pprError "ERROR: Can't see the data constructor(s) for _ccall_/_casm_ "
 181              (hcat [text thing, text "; type: ", ppr (PprForUser opt_PprUserLength) ty, text "(try compiling with -fno-prune-tydecls ..)\n"])
 182 \end{code}
 183
 184
 185 \begin{code}
 186 boxResult :: 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 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,
 196   -- which has a single, primitive-typed arg.
 197   | (maybeToBool maybe_data_type) &&                       -- Data type
 198     (null other_data_cons) &&                              -- Just one constr
 199     not (null data_con_arg_tys) && null other_args_tys  && -- Just one arg
 200     isPrimType the_prim_result_ty                          -- of primitive type
 201   =
 202     newSysLocalDs realWorldStatePrimTy          `thenDs` \ prim_state_id ->
 203     newSysLocalDs the_prim_result_ty            `thenDs` \ prim_result_id ->
 204
 205     mkConDs the_data_con (map TyArg tycon_arg_tys ++ [VarArg (Var prim_result_id)]) `thenDs` \ the_result ->
 206
 207     mkConDs stRetDataCon
 208             [TyArg realWorldTy, TyArg result_ty, VarArg (Var prim_state_id), VarArg the_result]
 209                                                         `thenDs` \ the_pair ->
 210     let
 211         the_alt = (state_and_prim_datacon, [prim_state_id, prim_result_id], the_pair)
 212     in
 213     returnDs (state_and_prim_ty,
 214               \prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
 215     )
 216
 217   -- Data types with a single nullary constructor
 218   | (maybeToBool maybe_data_type) &&                            -- Data type
 219     (null other_data_cons) &&                                   -- Just one constr
 220     (null data_con_arg_tys)
 221   =
 222     newSysLocalDs realWorldStatePrimTy          `thenDs` \ prim_state_id ->
 223
 224     mkConDs stRetDataCon
 225             [TyArg realWorldTy, TyArg result_ty, VarArg (Var prim_state_id), VarArg (Var unitDataCon)]
 226                                                 `thenDs` \ the_pair ->
 227
 228     let
 229         the_alt  = (stateDataCon, [prim_state_id], the_pair)
 230     in
 231     returnDs (realWorldStateTy,
 232               \prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
 233     )
 234
 235   | otherwise
 236   = pprPanic "boxResult: " (ppr PprDebug result_ty)
 237
 238   where
 239     maybe_data_type                        = maybeAppDataTyConExpandingDicts result_ty
 240     Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type
 241     (the_data_con : other_data_cons)       = data_cons
 242
 243     data_con_arg_tys                       = dataConArgTys the_data_con tycon_arg_tys
 244     (the_prim_result_ty : other_args_tys)  = data_con_arg_tys
 245
 246     (state_and_prim_datacon, state_and_prim_ty) = getStatePairingConInfo the_prim_result_ty
 247 \end{code}
 248