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