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, mkTupleCon )
  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, eqTy, maybeBoxedPrimType )
  27 import TysPrim          ( byteArrayPrimTy, realWorldTy,  realWorldStatePrimTy )
  28 import TysWiredIn       ( getStatePairingConInfo,
  29                           realWorldStateTy, stateDataCon,
  30                           stringTy
  31                         )
  32 import Util             ( pprPanic, pprError, panic )
  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
 151   | otherwise
 152   = pprPanic "unboxArg: " (ppr PprDebug arg_ty)
 153   where
 154     arg_ty = coreExprType arg
 155
 156     maybe_boxed_prim_arg_ty = maybeBoxedPrimType arg_ty
 157     (Just (box_data_con, the_prim_arg_ty)) = maybe_boxed_prim_arg_ty
 158
 159     maybe_data_type                        = maybeAppDataTyConExpandingDicts arg_ty
 160     is_data_type                           = maybeToBool maybe_data_type
 161     (Just (tycon, tycon_arg_tys, data_cons)) = maybe_data_type
 162     (the_data_con : other_data_cons)       = data_cons
 163
 164     data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys
 165     (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
 166
 167 can't_see_datacons_error thing ty
 168   = pprError "ERROR: Can't see the data constructor(s) for _ccall_/_casm_ "
 169              (ppBesides [ppStr thing, ppStr "; type: ", ppr PprForUser ty])
 170 \end{code}
 171
 172
 173 \begin{code}
 174 tuple_con_2 = mkTupleCon 2 -- out here to avoid CAF (sigh)
 175 covar_tuple_con_0 = Var (mkTupleCon 0) -- ditto
 176
 177 boxResult :: Type                               -- Type of desired result
 178           -> DsM (Type,                 -- Type of the result of the ccall itself
 179                   CoreExpr -> CoreExpr) -- Wrapper for the ccall
 180                                                         -- to box the result
 181 boxResult result_ty
 182   | null data_cons
 183   -- oops! can't see the data constructors
 184   = can't_see_datacons_error "result" result_ty
 185
 186   -- Data types with a single constructor, which has a single, primitive-typed arg
 187   | (maybeToBool maybe_data_type) &&                            -- Data type
 188     (null other_data_cons) &&                                   -- Just one constr
 189     not (null data_con_arg_tys) && null other_args_tys  &&      -- Just one arg
 190     isPrimType the_prim_result_ty                               -- of primitive type
 191   =
 192     newSysLocalDs realWorldStatePrimTy                          `thenDs` \ prim_state_id ->
 193     newSysLocalDs the_prim_result_ty                            `thenDs` \ prim_result_id ->
 194
 195     mkConDs stateDataCon [realWorldTy] [Var prim_state_id]      `thenDs` \ new_state ->
 196     mkConDs the_data_con tycon_arg_tys [Var prim_result_id]     `thenDs` \ the_result ->
 197
 198     mkConDs tuple_con_2
 199             [result_ty, realWorldStateTy]
 200             [the_result, new_state]                             `thenDs` \ the_pair ->
 201     let
 202         the_alt = (state_and_prim_datacon, [prim_state_id, prim_result_id], the_pair)
 203     in
 204     returnDs (state_and_prim_ty,
 205               \prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
 206     )
 207
 208   -- Data types with a single nullary constructor
 209   | (maybeToBool maybe_data_type) &&                            -- Data type
 210     (null other_data_cons) &&                                   -- Just one constr
 211     (null data_con_arg_tys)
 212   =
 213     newSysLocalDs realWorldStatePrimTy                          `thenDs` \ prim_state_id ->
 214
 215     mkConDs stateDataCon [realWorldTy] [Var prim_state_id]      `thenDs` \ new_state ->
 216
 217     mkConDs tuple_con_2
 218             [result_ty, realWorldStateTy]
 219             [covar_tuple_con_0, new_state]      `thenDs` \ the_pair ->
 220
 221     let
 222         the_alt  = (stateDataCon, [prim_state_id], the_pair)
 223     in
 224     returnDs (realWorldStateTy,
 225               \prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
 226     )
 227
 228   | otherwise
 229   = pprPanic "boxResult: " (ppr PprDebug result_ty)
 230
 231   where
 232     maybe_data_type                        = maybeAppDataTyConExpandingDicts result_ty
 233     Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type
 234     (the_data_con : other_data_cons)       = data_cons
 235
 236     data_con_arg_tys                       = dataConArgTys the_data_con tycon_arg_tys
 237     (the_prim_result_ty : other_args_tys)  = data_con_arg_tys
 238
 239     (state_and_prim_datacon, state_and_prim_ty) = getStatePairingConInfo the_prim_result_ty
 240 \end{code}
 241