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 CoreSyn
  14
  15 import DsMonad
  16 import DsUtils
  17
  18 import CoreUtils        ( coreExprType )
  19 import Id               ( dataConArgTys )
  20 import Maybes           ( maybeToBool )
  21 import PprStyle         ( PprStyle(..) )
  22 import PprType          ( GenType{-instances-} )
  23 import Pretty
  24 import PrelVals         ( packStringForCId )
  25 import PrimOp           ( PrimOp(..) )
  26 import Type             ( isPrimType, maybeAppDataTyConExpandingDicts, maybeAppTyCon,
  27                           eqTy, maybeBoxedPrimType )
  28 import TysPrim          ( byteArrayPrimTy, realWorldTy,  realWorldStatePrimTy,
  29                           byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
  30 import TysWiredIn       ( getStatePairingConInfo,
  31                           realWorldStateTy, stateDataCon, pairDataCon, unitDataCon,
  32                           stringTy
  33                         )
  34 import Util             ( pprPanic, pprError, panic )
  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 type)
  78         -> DsM CoreExpr
  79
  80 dsCCall label args may_gc is_asm result_ty
  81   = newSysLocalDs realWorldStateTy      `thenDs` \ old_s ->
  82
  83     mapAndUnzipDs unboxArg (Var old_s : args)   `thenDs` \ (final_args, arg_wrappers) ->
  84
  85     boxResult result_ty                         `thenDs` \ (final_result_ty, res_wrapper) ->
  86
  87     let
  88         the_ccall_op = CCallOp label is_asm may_gc
  89                                (map coreExprType final_args)
  90                                final_result_ty
  91     in
  92     mkPrimDs the_ccall_op (map VarArg final_args) `thenDs` \ the_prim_app ->
  93     let
  94         the_body = foldr ($) (res_wrapper the_prim_app) arg_wrappers
  95     in
  96     returnDs (Lam (ValBinder old_s) the_body)
  97 \end{code}
  98
  99 \begin{code}
 100 unboxArg :: CoreExpr                    -- The supplied argument
 101          -> DsM (CoreExpr,              -- To pass as the actual argument
 102                  CoreExpr -> CoreExpr   -- Wrapper to unbox the arg
 103                 )
 104 unboxArg arg
 105
 106   -- Primitive types
 107   -- ADR Question: can this ever be used?  None of the PrimTypes are
 108   -- instances of the CCallable class.
 109   --
 110   -- SOF response:
 111   --    Oh yes they are, I've just added them :-) Having _ccall_ and _casm_
 112   --  that accept unboxed arguments is a Good Thing if you have a stub generator
 113   --  which generates the boiler-plate box-unbox code for you, i.e., it may help
 114   --  us nuke this very module :-)
 115   --
 116   | isPrimType arg_ty
 117   = returnDs (arg, \body -> body)
 118
 119   -- Strings
 120   | arg_ty `eqTy` stringTy
 121   -- ToDo (ADR): - allow synonyms of Strings too?
 122   = newSysLocalDs byteArrayPrimTy               `thenDs` \ prim_arg ->
 123     mkAppDs (Var packStringForCId) [VarArg arg] `thenDs` \ pack_appn ->
 124     returnDs (Var prim_arg,
 125               \body -> Case pack_appn (PrimAlts []
 126                                                     (BindDefault prim_arg body))
 127     )
 128
 129   | null data_cons
 130     -- oops: we can't see the data constructors!!!
 131   = can't_see_datacons_error "argument" arg_ty
 132
 133   -- Byte-arrays, both mutable and otherwise; hack warning
 134   | is_data_type &&
 135     length data_con_arg_tys == 2 &&
 136     maybeToBool maybe_arg2_tycon &&
 137     (arg2_tycon ==  byteArrayPrimTyCon ||
 138      arg2_tycon ==  mutableByteArrayPrimTyCon)
 139     -- and, of course, it is an instance of CCallable
 140   = newSysLocalsDs data_con_arg_tys             `thenDs` \ vars@[ixs_var, arr_cts_var] ->
 141     returnDs (Var arr_cts_var,
 142               \ body -> Case arg (AlgAlts [(the_data_con,vars,body)]
 143                                               NoDefault)
 144     )
 145
 146   -- Data types with a single constructor, which has a single, primitive-typed arg
 147   | maybeToBool maybe_boxed_prim_arg_ty
 148   = newSysLocalDs the_prim_arg_ty               `thenDs` \ prim_arg ->
 149     returnDs (Var prim_arg,
 150               \ body -> Case arg (AlgAlts [(box_data_con,[prim_arg],body)]
 151                                               NoDefault)
 152     )
 153
 154   | otherwise
 155   = pprPanic "unboxArg: " (ppr PprDebug arg_ty)
 156   where
 157     arg_ty = coreExprType arg
 158
 159     maybe_boxed_prim_arg_ty = maybeBoxedPrimType arg_ty
 160     (Just (box_data_con, the_prim_arg_ty)) = maybe_boxed_prim_arg_ty
 161
 162     maybe_data_type                        = maybeAppDataTyConExpandingDicts arg_ty
 163     is_data_type                           = maybeToBool maybe_data_type
 164     (Just (tycon, tycon_arg_tys, data_cons)) = maybe_data_type
 165     (the_data_con : other_data_cons)       = data_cons
 166
 167     data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys
 168     (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
 169
 170     maybe_arg2_tycon = maybeAppTyCon data_con_arg_ty2
 171     Just (arg2_tycon,_) = maybe_arg2_tycon
 172
 173 can't_see_datacons_error thing ty
 174   = pprError "ERROR: Can't see the data constructor(s) for _ccall_/_casm_ "
 175              (ppBesides [ppStr thing, ppStr "; type: ", ppr PprForUser ty])
 176 \end{code}
 177
 178
 179 \begin{code}
 180 boxResult :: Type                               -- Type of desired result
 181           -> DsM (Type,                 -- Type of the result of the ccall itself
 182                   CoreExpr -> CoreExpr) -- Wrapper for the ccall
 183                                                         -- to box the result
 184 boxResult result_ty
 185   | null data_cons
 186   -- oops! can't see the data constructors
 187   = can't_see_datacons_error "result" result_ty
 188
 189   -- Data types with a single constructor, which has a single, primitive-typed arg
 190   | (maybeToBool maybe_data_type) &&                            -- Data type
 191     (null other_data_cons) &&                                   -- Just one constr
 192     not (null data_con_arg_tys) && null other_args_tys  &&      -- Just one arg
 193     isPrimType the_prim_result_ty                               -- of primitive type
 194   =
 195     newSysLocalDs realWorldStatePrimTy                  `thenDs` \ prim_state_id ->
 196     newSysLocalDs the_prim_result_ty                    `thenDs` \ prim_result_id ->
 197
 198     mkConDs stateDataCon [TyArg realWorldTy, VarArg (Var prim_state_id)]  `thenDs` \ new_state ->
 199     mkConDs the_data_con (map TyArg tycon_arg_tys ++ [VarArg (Var prim_result_id)]) `thenDs` \ the_result ->
 200
 201     mkConDs pairDataCon
 202             [TyArg result_ty, TyArg realWorldStateTy, VarArg the_result, VarArg new_state]
 203                                                         `thenDs` \ the_pair ->
 204     let
 205         the_alt = (state_and_prim_datacon, [prim_state_id, prim_result_id], the_pair)
 206     in
 207     returnDs (state_and_prim_ty,
 208               \prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
 209     )
 210
 211   -- Data types with a single nullary constructor
 212   | (maybeToBool maybe_data_type) &&                            -- Data type
 213     (null other_data_cons) &&                                   -- Just one constr
 214     (null data_con_arg_tys)
 215   =
 216     newSysLocalDs realWorldStatePrimTy          `thenDs` \ prim_state_id ->
 217
 218     mkConDs stateDataCon [TyArg realWorldTy, VarArg (Var prim_state_id)]
 219                                                 `thenDs` \ new_state ->
 220     mkConDs pairDataCon
 221             [TyArg result_ty, TyArg realWorldStateTy, VarArg (Var unitDataCon), VarArg new_state]
 222                                                 `thenDs` \ the_pair ->
 223
 224     let
 225         the_alt  = (stateDataCon, [prim_state_id], the_pair)
 226     in
 227     returnDs (realWorldStateTy,
 228               \prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
 229     )
 230
 231   | otherwise
 232   = pprPanic "boxResult: " (ppr PprDebug result_ty)
 233
 234   where
 235     maybe_data_type                        = maybeAppDataTyConExpandingDicts result_ty
 236     Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type
 237     (the_data_con : other_data_cons)       = data_cons
 238
 239     data_con_arg_tys                       = dataConArgTys the_data_con tycon_arg_tys
 240     (the_prim_result_ty : other_args_tys)  = data_con_arg_tys
 241
 242     (state_and_prim_datacon, state_and_prim_ty) = getStatePairingConInfo the_prim_result_ty
 243 \end{code}
 244