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-} )
  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 Util             ( pprPanic, pprError, panic )
  31
  32 maybeBoxedPrimType = panic "DsCCall.maybeBoxedPrimType"
  33 \end{code}
  34
  35 Desugaring of @ccall@s consists of adding some state manipulation,
  36 unboxing any boxed primitive arguments and boxing the result if
  37 desired.
  38
  39 The state stuff just consists of adding in
  40 @\ s -> case s of { S# s# -> ... }@ in an appropriate place.
  41
  42 The unboxing is straightforward, as all information needed to unbox is
  43 available from the type.  For each boxed-primitive argument, we
  44 transform:
  45 \begin{verbatim}
  46    _ccall_ foo [ r, t1, ... tm ] e1 ... em
  47    |
  48    |
  49    V
  50    case e1 of { T1# x1# ->
  51    ...
  52    case em of { Tm# xm# -> xm#
  53    ccall# foo [ r, t1#, ... tm# ] x1# ... xm#
  54    } ... }
  55 \end{verbatim}
  56
  57 The reboxing of a @_ccall_@ result is a bit tricker: the types don't
  58 contain information about the state-pairing functions so we have to
  59 keep a list of \tr{(type, s-p-function)} pairs.  We transform as
  60 follows:
  61 \begin{verbatim}
  62    ccall# foo [ r, t1#, ... tm# ] e1# ... em#
  63    |
  64    |
  65    V
  66    \ s# -> case (ccall# foo [ r, t1#, ... tm# ] s# e1# ... em#) of
  67           (StateAnd<r># result# state#) -> (R# result#, realWorld#)
  68 \end{verbatim}
  69
  70 \begin{code}
  71 dsCCall :: FAST_STRING          -- C routine to invoke
  72         -> [CoreExpr]   -- Arguments (desugared)
  73         -> Bool                 -- True <=> might cause Haskell GC
  74         -> Bool                 -- True <=> really a "_casm_"
  75         -> Type         -- Type of the result (a boxed-prim type)
  76         -> DsM CoreExpr
  77
  78 dsCCall label args may_gc is_asm result_ty
  79   = newSysLocalDs realWorldStateTy      `thenDs` \ old_s ->
  80
  81     mapAndUnzipDs unboxArg (Var old_s : args)   `thenDs` \ (final_args, arg_wrappers) ->
  82
  83     boxResult result_ty                         `thenDs` \ (final_result_ty, res_wrapper) ->
  84
  85     let
  86         the_ccall_op = CCallOp label is_asm may_gc
  87                                (map coreExprType final_args)
  88                                final_result_ty
  89     in
  90     mkPrimDs the_ccall_op
  91                [] -- ***NOTE*** no ty apps; the types are inside the_ccall_op.
  92                final_args       `thenDs` \ the_prim_app ->
  93     let
  94         the_body = foldr apply (res_wrapper the_prim_app) arg_wrappers
  95     in
  96     returnDs (Lam (ValBinder old_s) the_body)
  97   where
  98     apply f x = f x
  99 \end{code}
 100
 101 \begin{code}
 102 unboxArg :: CoreExpr                    -- The supplied argument
 103          -> DsM (CoreExpr,                      -- To pass as the actual argument
 104                  CoreExpr -> CoreExpr   -- Wrapper to unbox the arg
 105                 )
 106 unboxArg arg
 107
 108   -- Primitive types
 109   -- ADR Question: can this ever be used?  None of the PrimTypes are
 110   -- instances of the _CCallable class.
 111   | isPrimType arg_ty
 112   = returnDs (arg, \body -> body)
 113
 114   -- Strings
 115   | arg_ty `eqTy` stringTy
 116   -- ToDo (ADR): - allow synonyms of Strings too?
 117   = newSysLocalDs byteArrayPrimTy               `thenDs` \ prim_arg ->
 118     mkAppDs (Var packStringForCId) [] [arg]     `thenDs` \ pack_appn ->
 119     returnDs (Var prim_arg,
 120               \body -> Case pack_appn (PrimAlts []
 121                                                     (BindDefault prim_arg body))
 122     )
 123
 124   | null data_cons
 125     -- oops: we can't see the data constructors!!!
 126   = can't_see_datacons_error "argument" arg_ty
 127
 128   -- Byte-arrays, both mutable and otherwise
 129   -- (HACKy method -- but we really don't want the TyCons wired-in...) [WDP 94/10]
 130   | is_data_type &&
 131     length data_con_arg_tys == 2 &&
 132     not (isPrimType data_con_arg_ty1) &&
 133     isPrimType data_con_arg_ty2
 134     -- and, of course, it is an instance of _CCallable
 135 --  ( tycon == byteArrayTyCon ||
 136 --    tycon == mutableByteArrayTyCon )
 137   = newSysLocalsDs data_con_arg_tys             `thenDs` \ vars@[ixs_var, arr_cts_var] ->
 138     returnDs (Var arr_cts_var,
 139               \ body -> Case arg (AlgAlts [(the_data_con,vars,body)]
 140                                               NoDefault)
 141     )
 142
 143   -- Data types with a single constructor, which has a single, primitive-typed arg
 144   | maybeToBool maybe_boxed_prim_arg_ty
 145   = newSysLocalDs the_prim_arg_ty               `thenDs` \ prim_arg ->
 146     returnDs (Var prim_arg,
 147               \ body -> Case arg (AlgAlts [(box_data_con,[prim_arg],body)]
 148                                               NoDefault)
 149     )
 150   -- ... continued below ....
 151 \end{code}
 152
 153 As an experiment, I'm going to unpack any "acceptably small"
 154 enumeration.  This code will never get used in the main version
 155 because enumerations would have triggered type errors but I've
 156 disabled type-checking in my version. ADR
 157
 158 To Will: It might be worth leaving this in (but commented out) until
 159 we decide what's happening with enumerations. ADR
 160
 161 \begin{code}
 162 #if 0
 163   -- MAYBE LATER:
 164   -- Data types with a nullary constructors (enumeration)
 165   | isEnumerationType arg_ty  &&                                -- enumeration
 166     (length data_cons) <= 5                                     -- "acceptably short"
 167   = newSysLocalDs the_prim_arg_ty               `thenDs` \ prim_arg ->
 168
 169     let
 170       alts = [ (con, [], mkMachInt i) | (con,i) <- data_cons `zip` [0..] ]
 171       arg_tag = Case arg (AlgAlts alts) NoDefault
 172     in
 173
 174     returnDs (Var prim_arg,
 175               \ body -> Case arg_tag (PrimAlts [(prim_arg, body)] NoDefault)
 176     )
 177 #endif
 178 \end{code}
 179
 180 \begin{code}
 181   -- ... continued from above ....
 182   | otherwise
 183   = pprPanic "unboxArg: " (ppr PprDebug arg_ty)
 184   where
 185     arg_ty = coreExprType arg
 186
 187     maybe_boxed_prim_arg_ty = maybeBoxedPrimType arg_ty
 188     (Just (box_data_con, the_prim_arg_ty)) = maybe_boxed_prim_arg_ty
 189
 190     maybe_data_type                        = maybeAppDataTyCon arg_ty
 191     is_data_type                           = maybeToBool maybe_data_type
 192     (Just (tycon, tycon_arg_tys, data_cons)) = maybe_data_type
 193     (the_data_con : other_data_cons)       = data_cons
 194
 195     (_, data_con_arg_tys, _) = getInstantiatedDataConSig the_data_con tycon_arg_tys
 196     (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
 197
 198 can't_see_datacons_error thing ty
 199   = pprError "ERROR: Can't see the data constructor(s) for _ccall_/_casm_ "
 200              (ppBesides [ppStr thing, ppStr "; type: ", ppr PprForUser ty])
 201 \end{code}
 202
 203
 204 \begin{code}
 205 tuple_con_2 = mkTupleCon 2 -- out here to avoid CAF (sigh)
 206 covar_tuple_con_0 = Var (mkTupleCon 0) -- ditto
 207
 208 boxResult :: Type                               -- Type of desired result
 209           -> DsM (Type,                 -- Type of the result of the ccall itself
 210                   CoreExpr -> CoreExpr) -- Wrapper for the ccall
 211                                                         -- to box the result
 212 boxResult result_ty
 213   | null data_cons
 214   -- oops! can't see the data constructors
 215   = can't_see_datacons_error "result" result_ty
 216
 217   -- Data types with a single constructor, which has a single, primitive-typed arg
 218   | (maybeToBool maybe_data_type) &&                            -- Data type
 219     (null other_data_cons) &&                                   -- Just one constr
 220     not (null data_con_arg_tys) && null other_args_tys  &&      -- Just one arg
 221     isPrimType the_prim_result_ty                               -- of primitive type
 222   =
 223     newSysLocalDs realWorldStatePrimTy                          `thenDs` \ prim_state_id ->
 224     newSysLocalDs the_prim_result_ty                            `thenDs` \ prim_result_id ->
 225
 226     mkConDs stateDataCon [realWorldTy] [Var prim_state_id]      `thenDs` \ new_state ->
 227     mkConDs the_data_con tycon_arg_tys [Var prim_result_id]     `thenDs` \ the_result ->
 228
 229     mkConDs tuple_con_2
 230             [result_ty, realWorldStateTy]
 231             [the_result, new_state]                             `thenDs` \ the_pair ->
 232     let
 233         the_alt = (state_and_prim_datacon, [prim_state_id, prim_result_id], the_pair)
 234     in
 235     returnDs (state_and_prim_ty,
 236               \prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
 237     )
 238
 239   -- Data types with a single nullary constructor
 240   | (maybeToBool maybe_data_type) &&                            -- Data type
 241     (null other_data_cons) &&                                   -- Just one constr
 242     (null data_con_arg_tys)
 243   =
 244     newSysLocalDs realWorldStatePrimTy                          `thenDs` \ prim_state_id ->
 245
 246     mkConDs stateDataCon [realWorldTy] [Var prim_state_id]      `thenDs` \ new_state ->
 247
 248     mkConDs tuple_con_2
 249             [result_ty, realWorldStateTy]
 250             [covar_tuple_con_0, new_state]      `thenDs` \ the_pair ->
 251
 252     let
 253         the_alt  = (stateDataCon, [prim_state_id], the_pair)
 254     in
 255     returnDs (realWorldStateTy,
 256               \prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
 257     )
 258
 259 #if 0
 260     -- MAYBE LATER???
 261
 262   -- Data types with several nullary constructors (Enumerated types)
 263   | isEnumerationType result_ty &&                              -- Enumeration
 264     (length data_cons) <= 5                                     -- fairly short
 265   =
 266     newSysLocalDs realWorldStatePrimTy                          `thenDs` \ prim_state_id ->
 267     newSysLocalDs intPrimTy                                     `thenDs` \ prim_result_id ->
 268
 269     mkConDs stateDataCon [realWorldTy] [Var prim_state_id]      `thenDs` \ new_state ->
 270
 271     let
 272       alts = [ (mkMachInt i, con) | (i, con) <- [0..] `zip` data_cons ]
 273       the_result = Case prim_result_id (PrimAlts alts) NoDefault
 274     in
 275
 276     mkConDs (mkTupleCon 2)
 277               [result_ty, realWorldStateTy]
 278               [the_result, new_state]                           `thenDs` \ the_pair ->
 279     let
 280         the_alt = (state_and_prim_datacon, [prim_state_id, prim_result_id], the_pair)
 281     in
 282     returnDs (state_and_prim_ty,
 283               \prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
 284     )
 285 #endif
 286
 287   | otherwise
 288   = pprPanic "boxResult: " (ppr PprDebug result_ty)
 289
 290   where
 291     maybe_data_type                        = maybeAppDataTyCon result_ty
 292     Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type
 293     (the_data_con : other_data_cons)       = data_cons
 294
 295     (_, data_con_arg_tys, _)               = getInstantiatedDataConSig the_data_con tycon_arg_tys
 296     (the_prim_result_ty : other_args_tys)  = data_con_arg_tys
 297
 298     (state_and_prim_datacon, state_and_prim_ty) = getStatePairingConInfo the_prim_result_ty
 299 \end{code}
 300