ghc/compiler/deSugar/DsCCall.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1994-1998
   3 %
   4 \section[DsCCall]{Desugaring \tr{_ccall_}s and \tr{_casm_}s}
   5
   6 \begin{code}
   7 module DsCCall
   8         ( dsCCall
   9         , mkCCall
  10         , unboxArg
  11         , boxResult
  12         , resultWrapper
  13         ) where
  14
  15 #include "HsVersions.h"
  16
  17 import CoreSyn
  18
  19 import DsMonad
  20
  21 import CoreUtils        ( exprType, mkCoerce )
  22 import Id               ( mkWildId )
  23 import MkId             ( mkCCallOpId, realWorldPrimId )
  24 import Maybes           ( maybeToBool )
  25 import PrimOp           ( CCall(..), CCallTarget(..) )
  26 import DataCon          ( splitProductType_maybe, dataConSourceArity, dataConWrapId )
  27 import CallConv
  28 import Type             ( isUnLiftedType, splitAlgTyConApp_maybe, mkFunTys,
  29                           splitTyConApp_maybe, tyVarsOfType, mkForAllTys,
  30                           isNewType, repType, isUnLiftedType, mkFunTy, mkTyConApp,
  31                           Type
  32                         )
  33 import TysPrim          ( realWorldStatePrimTy,
  34                           byteArrayPrimTyCon, mutableByteArrayPrimTyCon, intPrimTy
  35                         )
  36 import TysWiredIn       ( unitDataConId,
  37                           unboxedSingletonDataCon, unboxedPairDataCon,
  38                           unboxedSingletonTyCon, unboxedPairTyCon,
  39                           boolTy, trueDataCon, falseDataCon,
  40                           trueDataConId, falseDataConId, unitTy
  41                         )
  42 import Literal          ( mkMachInt )
  43 import CStrings         ( CLabelString )
  44 import Unique           ( Unique, hasKey, ioTyConKey )
  45 import VarSet           ( varSetElems )
  46 import Outputable
  47 \end{code}
  48
  49 Desugaring of @ccall@s consists of adding some state manipulation,
  50 unboxing any boxed primitive arguments and boxing the result if
  51 desired.
  52
  53 The state stuff just consists of adding in
  54 @PrimIO (\ s -> case s of { S# s# -> ... })@ in an appropriate place.
  55
  56 The unboxing is straightforward, as all information needed to unbox is
  57 available from the type.  For each boxed-primitive argument, we
  58 transform:
  59 \begin{verbatim}
  60    _ccall_ foo [ r, t1, ... tm ] e1 ... em
  61    |
  62    |
  63    V
  64    case e1 of { T1# x1# ->
  65    ...
  66    case em of { Tm# xm# -> xm#
  67    ccall# foo [ r, t1#, ... tm# ] x1# ... xm#
  68    } ... }
  69 \end{verbatim}
  70
  71 The reboxing of a @_ccall_@ result is a bit tricker: the types don't
  72 contain information about the state-pairing functions so we have to
  73 keep a list of \tr{(type, s-p-function)} pairs.  We transform as
  74 follows:
  75 \begin{verbatim}
  76    ccall# foo [ r, t1#, ... tm# ] e1# ... em#
  77    |
  78    |
  79    V
  80    \ s# -> case (ccall# foo [ r, t1#, ... tm# ] s# e1# ... em#) of
  81           (StateAnd<r># result# state#) -> (R# result#, realWorld#)
  82 \end{verbatim}
  83
  84 \begin{code}
  85 dsCCall :: CLabelString -- C routine to invoke
  86         -> [CoreExpr]   -- Arguments (desugared)
  87         -> Bool         -- True <=> might cause Haskell GC
  88         -> Bool         -- True <=> really a "_casm_"
  89         -> Type         -- Type of the result: IO t
  90         -> DsM CoreExpr
  91
  92 dsCCall lbl args may_gc is_asm result_ty
  93   = mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) ->
  94     boxResult result_ty         `thenDs` \ (ccall_result_ty, res_wrapper) ->
  95     getUniqueDs                 `thenDs` \ uniq ->
  96     let
  97         the_ccall    = CCall (StaticTarget lbl) is_asm may_gc cCallConv
  98         the_prim_app = mkCCall uniq the_ccall unboxed_args ccall_result_ty
  99     in
 100     returnDs (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
 101
 102 mkCCall :: Unique -> CCall
 103         -> [CoreExpr]   -- Args
 104         -> Type         -- Result type
 105         -> CoreExpr
 106 -- Construct the ccall.  The only tricky bit is that the ccall Id should have
 107 -- no free vars, so if any of the arg tys do we must give it a polymorphic type.
 108 --      [I forget *why* it should have no free vars!]
 109 -- For example:
 110 --      mkCCall ... [s::StablePtr (a->b), x::Addr, c::Char]
 111 --
 112 -- Here we build a ccall thus
 113 --      (ccallid::(forall a b.  StablePtr (a -> b) -> Addr -> Char -> IO Addr))
 114 --                      a b s x c
 115 mkCCall uniq the_ccall val_args res_ty
 116   = mkApps (mkVarApps (Var the_ccall_id) tyvars) val_args
 117   where
 118     arg_tys = map exprType val_args
 119     body_ty = (mkFunTys arg_tys res_ty)
 120     tyvars  = varSetElems (tyVarsOfType body_ty)
 121     ty      = mkForAllTys tyvars body_ty
 122     the_ccall_id = mkCCallOpId uniq the_ccall ty
 123 \end{code}
 124
 125 \begin{code}
 126 unboxArg :: CoreExpr                    -- The supplied argument
 127          -> DsM (CoreExpr,              -- To pass as the actual argument
 128                  CoreExpr -> CoreExpr   -- Wrapper to unbox the arg
 129                 )
 130 -- Example: if the arg is e::Int, unboxArg will return
 131 --      (x#::Int#, \W. case x of I# x# -> W)
 132 -- where W is a CoreExpr that probably mentions x#
 133
 134 unboxArg arg
 135   -- Unlifted types: nothing to unbox
 136   | isUnLiftedType arg_ty
 137   = returnDs (arg, \body -> body)
 138
 139   -- Newtypes
 140   | isNewType arg_ty
 141   = unboxArg (mkCoerce (repType arg_ty) arg_ty arg)
 142
 143   -- Booleans
 144   | arg_ty == boolTy
 145   = newSysLocalDs intPrimTy             `thenDs` \ prim_arg ->
 146     returnDs (Var prim_arg,
 147               \ body -> Case (Case arg (mkWildId arg_ty)
 148                                        [(DataAlt falseDataCon,[],mkIntLit 0),
 149                                         (DataAlt trueDataCon, [],mkIntLit 1)])
 150                              prim_arg
 151                              [(DEFAULT,[],body)])
 152
 153   -- Data types with a single constructor, which has a single, primitive-typed arg
 154   -- This deals with Int, Float etc
 155   | is_product_type && data_con_arity == 1
 156   = ASSERT(isUnLiftedType data_con_arg_ty1 )    -- Typechecker ensures this
 157     newSysLocalDs arg_ty                `thenDs` \ case_bndr ->
 158     newSysLocalDs data_con_arg_ty1      `thenDs` \ prim_arg ->
 159     returnDs (Var prim_arg,
 160               \ body -> Case arg case_bndr [(DataAlt data_con,[prim_arg],body)]
 161     )
 162
 163   -- Byte-arrays, both mutable and otherwise; hack warning
 164   | is_product_type &&
 165     data_con_arity == 3 &&
 166     maybeToBool maybe_arg3_tycon &&
 167     (arg3_tycon ==  byteArrayPrimTyCon ||
 168      arg3_tycon ==  mutableByteArrayPrimTyCon)
 169     -- and, of course, it is an instance of CCallable
 170   = newSysLocalDs arg_ty                `thenDs` \ case_bndr ->
 171     newSysLocalsDs data_con_arg_tys     `thenDs` \ vars@[l_var, r_var, arr_cts_var] ->
 172     returnDs (Var arr_cts_var,
 173               \ body -> Case arg case_bndr [(DataAlt data_con,vars,body)]
 174     )
 175
 176   | otherwise
 177   = getSrcLocDs `thenDs` \ l ->
 178     pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
 179   where
 180     arg_ty     = exprType arg
 181     arg_rep_ty = repType arg_ty
 182
 183     maybe_product_type                            = splitProductType_maybe arg_ty
 184     is_product_type                               = maybeToBool maybe_product_type
 185     Just (tycon, _, data_con, data_con_arg_tys)   = maybe_product_type
 186     data_con_arity                                = dataConSourceArity data_con
 187     (data_con_arg_ty1 : _)                        = data_con_arg_tys
 188
 189     (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys
 190     maybe_arg3_tycon               = splitTyConApp_maybe data_con_arg_ty3
 191     Just (arg3_tycon,_)            = maybe_arg3_tycon
 192 \end{code}
 193
 194
 195 \begin{code}
 196 boxResult :: Type -> DsM (Type, CoreExpr -> CoreExpr)
 197
 198 -- Takes the result of the user-level ccall:
 199 --      either (IO t),
 200 --      or maybe just t for an side-effect-free call
 201 -- Returns a wrapper for the primitive ccall itself, along with the
 202 -- type of the result of the primitive ccall.  This result type
 203 -- will be of the form
 204 --      State# RealWorld -> (# State# RealWorld, t' #)
 205 -- where t' is the unwrapped form of t.  If t is simply (), then
 206 -- the result type will be
 207 --      State# RealWorld -> (# State# RealWorld #)
 208
 209 boxResult result_ty
 210   = case splitAlgTyConApp_maybe result_ty of
 211
 212         -- The result is IO t, so wrap the result in an IO constructor
 213         Just (io_tycon, [io_res_ty], [io_data_con]) | io_tycon `hasKey` ioTyConKey
 214                 -> mk_alt return_result
 215                           (resultWrapper io_res_ty)     `thenDs` \ (ccall_res_ty, the_alt) ->
 216                    newSysLocalDs realWorldStatePrimTy    `thenDs` \ state_id ->
 217                    let
 218                         wrap = \ the_call -> mkApps (Var (dataConWrapId io_data_con))
 219                                                     [Type io_res_ty, Lam state_id $
 220                                                                      Case (App the_call (Var state_id))
 221                                                                           (mkWildId ccall_res_ty)
 222                                                                           [the_alt]]
 223                    in
 224                    returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
 225                 where
 226                    return_result state ans = mkConApp unboxedPairDataCon
 227                                                       [Type realWorldStatePrimTy, Type io_res_ty,
 228                                                        state, ans]
 229
 230         -- It isn't, so do unsafePerformIO
 231         -- It's not conveniently available, so we inline it
 232         other -> mk_alt return_result
 233                         (resultWrapper result_ty)       `thenDs` \ (ccall_res_ty, the_alt) ->
 234                  let
 235                     wrap = \ the_call -> Case (App the_call (Var realWorldPrimId))
 236                                               (mkWildId ccall_res_ty)
 237                                               [the_alt]
 238                  in
 239                  returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
 240               where
 241                  return_result state ans = ans
 242   where
 243     mk_alt return_result (Nothing, wrap_result)
 244         =       -- The ccall returns ()
 245           newSysLocalDs realWorldStatePrimTy    `thenDs` \ state_id ->
 246           let
 247                 the_rhs      = return_result (Var state_id) (wrap_result (panic "boxResult"))
 248                 ccall_res_ty = mkTyConApp unboxedSingletonTyCon [realWorldStatePrimTy]
 249                 the_alt      = (DataAlt unboxedSingletonDataCon, [state_id], the_rhs)
 250           in
 251           returnDs (ccall_res_ty, the_alt)
 252
 253     mk_alt return_result (Just prim_res_ty, wrap_result)
 254         =       -- The ccall returns a non-() value
 255           newSysLocalDs realWorldStatePrimTy    `thenDs` \ state_id ->
 256           newSysLocalDs prim_res_ty             `thenDs` \ result_id ->
 257           let
 258                 the_rhs      = return_result (Var state_id) (wrap_result (Var result_id))
 259                 ccall_res_ty = mkTyConApp unboxedPairTyCon [realWorldStatePrimTy, prim_res_ty]
 260                 the_alt      = (DataAlt unboxedPairDataCon, [state_id, result_id], the_rhs)
 261           in
 262           returnDs (ccall_res_ty, the_alt)
 263
 264
 265 resultWrapper :: Type
 266               -> (Maybe Type,           -- Type of the expected result, if any
 267                   CoreExpr -> CoreExpr) -- Wrapper for the result
 268 resultWrapper result_ty
 269   -- Base case 1: primitive types
 270   | isUnLiftedType result_ty
 271   = (Just result_ty, \e -> e)
 272
 273   -- Base case 1: the unit type ()
 274   | result_ty == unitTy
 275   = (Nothing, \e -> Var unitDataConId)
 276
 277   | result_ty == boolTy
 278   = (Just intPrimTy, \e -> Case e (mkWildId intPrimTy)
 279                                   [(LitAlt (mkMachInt 0),[],Var falseDataConId),
 280                                    (DEFAULT             ,[],Var trueDataConId )])
 281
 282   -- Data types with a single constructor, which has a single arg
 283   | is_product_type && data_con_arity == 1
 284   = let
 285         (maybe_ty, wrapper)    = resultWrapper unwrapped_res_ty
 286         (unwrapped_res_ty : _) = data_con_arg_tys
 287     in
 288     (maybe_ty, \e -> mkApps (Var (dataConWrapId data_con))
 289                             (map Type tycon_arg_tys ++ [wrapper e]))
 290
 291   -- newtypes
 292   | isNewType result_ty
 293   = let
 294         rep_ty              = repType result_ty
 295         (maybe_ty, wrapper) = resultWrapper rep_ty
 296     in
 297     (maybe_ty, \e -> mkCoerce result_ty rep_ty (wrapper e))
 298
 299   | otherwise
 300   = pprPanic "resultWrapper" (ppr result_ty)
 301   where
 302     maybe_product_type                                      = splitProductType_maybe result_ty
 303     is_product_type                                         = maybeToBool maybe_product_type
 304     Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) = maybe_product_type
 305     data_con_arity                                          = dataConSourceArity data_con
 306 \end{code}