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 import Ubiq
  12
  13 import CoreSyn
  14
  15 import DsMonad
  16 import DsUtils
  17
  18 import CoreUtils        ( coreExprType )
  19 import Id               ( getInstantiatedDataConSig, mkTupleCon )
  20 import Maybes           ( maybeToBool )
  21 import PprStyle         ( PprStyle(..) )
  22 import PprType          ( GenType{-instances-}, GenTyVar{-instance-} )
  23 import PrelInfo         ( byteArrayPrimTy, getStatePairingConInfo,
  24                           packStringForCId, realWorldStatePrimTy,
  25                           realWorldStateTy, realWorldTy, stateDataCon,
  26                           stringTy )
  27 import Pretty
  28 import PrimOp           ( PrimOp(..) )
  29 import Type             ( isPrimType, maybeAppDataTyCon, eqTy )
  30 import TyVar            ( GenTyVar{-instance-} )
  31 import Unique           ( Unique{-instances-} )
  32 import Util             ( pprPanic, panic )
  33
  34 maybeBoxedPrimType = panic "DsCCall.maybeBoxedPrimType"
  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 @\ 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
  93                [] -- ***NOTE*** no ty apps; the types are inside the_ccall_op.
  94                final_args       `thenDs` \ the_prim_app ->
  95     let
  96         the_body = foldr apply (res_wrapper the_prim_app) arg_wrappers
  97     in
  98     returnDs (Lam (ValBinder old_s) the_body)
  99   where
 100     apply f x = f x
 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   | isPrimType arg_ty
 114   = returnDs (arg, \body -> body)
 115
 116   -- Strings
 117   | arg_ty `eqTy` stringTy
 118   -- ToDo (ADR): - allow synonyms of Strings too?
 119   = newSysLocalDs byteArrayPrimTy               `thenDs` \ prim_arg ->
 120     mkAppDs (Var packStringForCId) [] [arg]     `thenDs` \ pack_appn ->
 121     returnDs (Var prim_arg,
 122               \body -> Case pack_appn (PrimAlts []
 123                                                     (BindDefault prim_arg body))
 124     )
 125
 126   | null data_cons
 127     -- oops: we can't see the data constructors!!!
 128   = can't_see_datacons_error "argument" arg_ty
 129
 130   -- Byte-arrays, both mutable and otherwise
 131   -- (HACKy method -- but we really don't want the TyCons wired-in...) [WDP 94/10]
 132   | is_data_type &&
 133     length data_con_arg_tys == 2 &&
 134     not (isPrimType data_con_arg_ty1) &&
 135     isPrimType data_con_arg_ty2
 136     -- and, of course, it is an instance of _CCallable
 137 --  ( tycon == byteArrayTyCon ||
 138 --    tycon == mutableByteArrayTyCon )
 139   = newSysLocalsDs data_con_arg_tys             `thenDs` \ vars@[ixs_var, arr_cts_var] ->
 140     returnDs (Var arr_cts_var,
 141               \ body -> Case arg (AlgAlts [(the_data_con,vars,body)]
 142                                               NoDefault)
 143     )
 144
 145   -- Data types with a single constructor, which has a single, primitive-typed arg
 146   | maybeToBool maybe_boxed_prim_arg_ty
 147   = newSysLocalDs the_prim_arg_ty               `thenDs` \ prim_arg ->
 148     returnDs (Var prim_arg,
 149               \ body -> Case arg (AlgAlts [(box_data_con,[prim_arg],body)]
 150                                               NoDefault)
 151     )
 152   -- ... continued below ....
 153 \end{code}
 154
 155 As an experiment, I'm going to unpack any "acceptably small"
 156 enumeration.  This code will never get used in the main version
 157 because enumerations would have triggered type errors but I've
 158 disabled type-checking in my version. ADR
 159
 160 To Will: It might be worth leaving this in (but commented out) until
 161 we decide what's happening with enumerations. ADR
 162
 163 \begin{code}
 164 #if 0
 165   -- MAYBE LATER:
 166   -- Data types with a nullary constructors (enumeration)
 167   | isEnumerationType arg_ty  &&                                -- enumeration
 168     (length data_cons) <= 5                                     -- "acceptably short"
 169   = newSysLocalDs the_prim_arg_ty               `thenDs` \ prim_arg ->
 170
 171     let
 172       alts = [ (con, [], mkMachInt i) | (con,i) <- data_cons `zip` [0..] ]
 173       arg_tag = Case arg (AlgAlts alts) NoDefault
 174     in
 175
 176     returnDs (Var prim_arg,
 177               \ body -> Case arg_tag (PrimAlts [(prim_arg, body)] NoDefault)
 178     )
 179 #endif
 180 \end{code}
 181
 182 \begin{code}
 183   -- ... continued from above ....
 184   | otherwise
 185   = pprPanic "unboxArg: " (ppr PprDebug arg_ty)
 186   where
 187     arg_ty = coreExprType arg
 188
 189     maybe_boxed_prim_arg_ty = maybeBoxedPrimType arg_ty
 190     (Just (box_data_con, the_prim_arg_ty)) = maybe_boxed_prim_arg_ty
 191
 192     maybe_data_type                        = maybeAppDataTyCon arg_ty
 193     is_data_type                           = maybeToBool maybe_data_type
 194     (Just (tycon, tycon_arg_tys, data_cons)) = maybe_data_type
 195     (the_data_con : other_data_cons)       = data_cons
 196
 197     (_, data_con_arg_tys, _) = getInstantiatedDataConSig the_data_con tycon_arg_tys
 198     (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
 199
 200 can't_see_datacons_error thing ty
 201   = error (ppShow 100 (ppBesides [ppStr "ERROR: Can't see the data constructor(s) for _ccall_/_casm_ ", ppStr thing, ppStr "; type: ", ppr PprForUser ty]))
 202 \end{code}
 203
 204
 205 \begin{code}
 206 tuple_con_2 = mkTupleCon 2 -- out here to avoid CAF (sigh)
 207 covar_tuple_con_0 = Var (mkTupleCon 0) -- ditto
 208
 209 boxResult :: Type                               -- Type of desired result
 210           -> DsM (Type,                 -- Type of the result of the ccall itself
 211                   CoreExpr -> CoreExpr) -- Wrapper for the ccall
 212                                                         -- to box the result
 213 boxResult result_ty
 214   | null data_cons
 215   -- oops! can't see the data constructors
 216   = can't_see_datacons_error "result" result_ty
 217
 218   -- Data types with a single constructor, which has a single, primitive-typed arg
 219   | (maybeToBool maybe_data_type) &&                            -- Data type
 220     (null other_data_cons) &&                                   -- Just one constr
 221     not (null data_con_arg_tys) && null other_args_tys  &&      -- Just one arg
 222     isPrimType the_prim_result_ty                               -- of primitive type
 223   =
 224     newSysLocalDs realWorldStatePrimTy                          `thenDs` \ prim_state_id ->
 225     newSysLocalDs the_prim_result_ty                            `thenDs` \ prim_result_id ->
 226
 227     mkConDs stateDataCon [realWorldTy] [Var prim_state_id]      `thenDs` \ new_state ->
 228     mkConDs the_data_con tycon_arg_tys [Var prim_result_id]     `thenDs` \ the_result ->
 229
 230     mkConDs tuple_con_2
 231             [result_ty, realWorldStateTy]
 232             [the_result, new_state]                             `thenDs` \ the_pair ->
 233     let
 234         the_alt = (state_and_prim_datacon, [prim_state_id, prim_result_id], the_pair)
 235     in
 236     returnDs (state_and_prim_ty,
 237               \prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
 238     )
 239
 240   -- Data types with a single nullary constructor
 241   | (maybeToBool maybe_data_type) &&                            -- Data type
 242     (null other_data_cons) &&                                   -- Just one constr
 243     (null data_con_arg_tys)
 244   =
 245     newSysLocalDs realWorldStatePrimTy                          `thenDs` \ prim_state_id ->
 246
 247     mkConDs stateDataCon [realWorldTy] [Var prim_state_id]      `thenDs` \ new_state ->
 248
 249     mkConDs tuple_con_2
 250             [result_ty, realWorldStateTy]
 251             [covar_tuple_con_0, new_state]      `thenDs` \ the_pair ->
 252
 253     let
 254         the_alt  = (stateDataCon, [prim_state_id], the_pair)
 255     in
 256     returnDs (realWorldStateTy,
 257               \prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
 258     )
 259
 260 #if 0
 261     -- MAYBE LATER???
 262
 263   -- Data types with several nullary constructors (Enumerated types)
 264   | isEnumerationType result_ty &&                              -- Enumeration
 265     (length data_cons) <= 5                                     -- fairly short
 266   =
 267     newSysLocalDs realWorldStatePrimTy                          `thenDs` \ prim_state_id ->
 268     newSysLocalDs intPrimTy                                     `thenDs` \ prim_result_id ->
 269
 270     mkConDs stateDataCon [realWorldTy] [Var prim_state_id]      `thenDs` \ new_state ->
 271
 272     let
 273       alts = [ (mkMachInt i, con) | (i, con) <- [0..] `zip` data_cons ]
 274       the_result = Case prim_result_id (PrimAlts alts) NoDefault
 275     in
 276
 277     mkConDs (mkTupleCon 2)
 278               [result_ty, realWorldStateTy]
 279               [the_result, new_state]                           `thenDs` \ the_pair ->
 280     let
 281         the_alt = (state_and_prim_datacon, [prim_state_id, prim_result_id], the_pair)
 282     in
 283     returnDs (state_and_prim_ty,
 284               \prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
 285     )
 286 #endif
 287
 288   | otherwise
 289   = pprPanic "boxResult: " (ppr PprDebug result_ty)
 290
 291   where
 292     maybe_data_type                        = maybeAppDataTyCon result_ty
 293     Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type
 294     (the_data_con : other_data_cons)       = data_cons
 295
 296     (_, data_con_arg_tys, _)               = getInstantiatedDataConSig the_data_con tycon_arg_tys
 297     (the_prim_result_ty : other_args_tys)  = data_con_arg_tys
 298
 299     (state_and_prim_datacon, state_and_prim_ty) = getStatePairingConInfo the_prim_result_ty
 300 \end{code}
 301