ghc/compiler/deSugar/DsCCall.lhs

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