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 PrelNames        ( 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     maybe_product_type                          = splitProductType_maybe arg_ty
 182     is_product_type                             = maybeToBool maybe_product_type
 183     Just (_, _, data_con, data_con_arg_tys)     = maybe_product_type
 184     data_con_arity                              = dataConSourceArity data_con
 185     (data_con_arg_ty1 : _)                      = data_con_arg_tys
 186
 187     (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys
 188     maybe_arg3_tycon               = splitTyConApp_maybe data_con_arg_ty3
 189     Just (arg3_tycon,_)            = maybe_arg3_tycon
 190 \end{code}
 191
 192
 193 \begin{code}
 194 boxResult :: Type -> DsM (Type, CoreExpr -> CoreExpr)
 195
 196 -- Takes the result of the user-level ccall:
 197 --      either (IO t),
 198 --      or maybe just t for an side-effect-free call
 199 -- Returns a wrapper for the primitive ccall itself, along with the
 200 -- type of the result of the primitive ccall.  This result type
 201 -- will be of the form
 202 --      State# RealWorld -> (# State# RealWorld, t' #)
 203 -- where t' is the unwrapped form of t.  If t is simply (), then
 204 -- the result type will be
 205 --      State# RealWorld -> (# State# RealWorld #)
 206
 207 boxResult result_ty
 208   = case splitAlgTyConApp_maybe result_ty of
 209
 210         -- The result is IO t, so wrap the result in an IO constructor
 211         Just (io_tycon, [io_res_ty], [io_data_con]) | io_tycon `hasKey` ioTyConKey
 212                 -> mk_alt return_result
 213                           (resultWrapper io_res_ty)     `thenDs` \ (ccall_res_ty, the_alt) ->
 214                    newSysLocalDs realWorldStatePrimTy    `thenDs` \ state_id ->
 215                    let
 216                         wrap = \ the_call -> mkApps (Var (dataConWrapId io_data_con))
 217                                                     [Type io_res_ty, Lam state_id $
 218                                                                      Case (App the_call (Var state_id))
 219                                                                           (mkWildId ccall_res_ty)
 220                                                                           [the_alt]]
 221                    in
 222                    returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
 223                 where
 224                    return_result state ans = mkConApp unboxedPairDataCon
 225                                                       [Type realWorldStatePrimTy, Type io_res_ty,
 226                                                        state, ans]
 227
 228         -- It isn't, so do unsafePerformIO
 229         -- It's not conveniently available, so we inline it
 230         other -> mk_alt return_result
 231                         (resultWrapper result_ty)       `thenDs` \ (ccall_res_ty, the_alt) ->
 232                  let
 233                     wrap = \ the_call -> Case (App the_call (Var realWorldPrimId))
 234                                               (mkWildId ccall_res_ty)
 235                                               [the_alt]
 236                  in
 237                  returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
 238               where
 239                  return_result state ans = ans
 240   where
 241     mk_alt return_result (Nothing, wrap_result)
 242         =       -- The ccall returns ()
 243           newSysLocalDs realWorldStatePrimTy    `thenDs` \ state_id ->
 244           let
 245                 the_rhs      = return_result (Var state_id) (wrap_result (panic "boxResult"))
 246                 ccall_res_ty = mkTyConApp unboxedSingletonTyCon [realWorldStatePrimTy]
 247                 the_alt      = (DataAlt unboxedSingletonDataCon, [state_id], the_rhs)
 248           in
 249           returnDs (ccall_res_ty, the_alt)
 250
 251     mk_alt return_result (Just prim_res_ty, wrap_result)
 252         =       -- The ccall returns a non-() value
 253           newSysLocalDs realWorldStatePrimTy    `thenDs` \ state_id ->
 254           newSysLocalDs prim_res_ty             `thenDs` \ result_id ->
 255           let
 256                 the_rhs      = return_result (Var state_id) (wrap_result (Var result_id))
 257                 ccall_res_ty = mkTyConApp unboxedPairTyCon [realWorldStatePrimTy, prim_res_ty]
 258                 the_alt      = (DataAlt unboxedPairDataCon, [state_id, result_id], the_rhs)
 259           in
 260           returnDs (ccall_res_ty, the_alt)
 261
 262
 263 resultWrapper :: Type
 264               -> (Maybe Type,           -- Type of the expected result, if any
 265                   CoreExpr -> CoreExpr) -- Wrapper for the result
 266 resultWrapper result_ty
 267   -- Base case 1: primitive types
 268   | isUnLiftedType result_ty
 269   = (Just result_ty, \e -> e)
 270
 271   -- Base case 1: the unit type ()
 272   | result_ty == unitTy
 273   = (Nothing, \e -> Var unitDataConId)
 274
 275   | result_ty == boolTy
 276   = (Just intPrimTy, \e -> Case e (mkWildId intPrimTy)
 277                                   [(LitAlt (mkMachInt 0),[],Var falseDataConId),
 278                                    (DEFAULT             ,[],Var trueDataConId )])
 279
 280   -- Data types with a single constructor, which has a single arg
 281   | is_product_type && data_con_arity == 1
 282   = let
 283         (maybe_ty, wrapper)    = resultWrapper unwrapped_res_ty
 284         (unwrapped_res_ty : _) = data_con_arg_tys
 285     in
 286     (maybe_ty, \e -> mkApps (Var (dataConWrapId data_con))
 287                             (map Type tycon_arg_tys ++ [wrapper e]))
 288
 289   -- newtypes
 290   | isNewType result_ty
 291   = let
 292         rep_ty              = repType result_ty
 293         (maybe_ty, wrapper) = resultWrapper rep_ty
 294     in
 295     (maybe_ty, \e -> mkCoerce result_ty rep_ty (wrapper e))
 296
 297   | otherwise
 298   = pprPanic "resultWrapper" (ppr result_ty)
 299   where
 300     maybe_product_type                                  = splitProductType_maybe result_ty
 301     is_product_type                                     = maybeToBool maybe_product_type
 302     Just (_, tycon_arg_tys, data_con, data_con_arg_tys) = maybe_product_type
 303     data_con_arity                                      = dataConSourceArity data_con
 304 \end{code}