never executed always true always false
    1 {-
    2 (c) The University of Glasgow 2006
    3 (c) The AQUA Project, Glasgow University, 1994-1998
    4 
    5 
    6 Desugaring foreign calls
    7 -}
    8 
    9 
   10 
   11 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
   12 
   13 module GHC.HsToCore.Foreign.Call
   14    ( dsCCall
   15    , mkFCall
   16    , unboxArg
   17    , boxResult
   18    , resultWrapper
   19    )
   20 where
   21 
   22 import GHC.Prelude
   23 
   24 import GHC.Core
   25 
   26 import GHC.HsToCore.Monad
   27 import GHC.Core.Utils
   28 import GHC.Core.Make
   29 import GHC.Types.SourceText
   30 import GHC.Types.Id.Make
   31 import GHC.Types.ForeignCall
   32 import GHC.Core.DataCon
   33 import GHC.HsToCore.Utils
   34 
   35 import GHC.Tc.Utils.TcType
   36 import GHC.Core.Type
   37 import GHC.Core.Multiplicity
   38 import GHC.Core.Coercion
   39 import GHC.Builtin.Types.Prim
   40 import GHC.Core.TyCon
   41 import GHC.Builtin.Types
   42 import GHC.Types.Basic
   43 import GHC.Types.Literal
   44 import GHC.Builtin.Names
   45 import GHC.Driver.Session
   46 import GHC.Utils.Outputable
   47 import GHC.Utils.Panic
   48 import GHC.Utils.Panic.Plain
   49 
   50 import Data.Maybe
   51 
   52 {-
   53 Desugaring of @ccall@s consists of adding some state manipulation,
   54 unboxing any boxed primitive arguments and boxing the result if
   55 desired.
   56 
   57 The state stuff just consists of adding in
   58 @PrimIO (\ s -> case s of { State# s# -> ... })@ in an appropriate place.
   59 
   60 The unboxing is straightforward, as all information needed to unbox is
   61 available from the type.  For each boxed-primitive argument, we
   62 transform:
   63 \begin{verbatim}
   64    _ccall_ foo [ r, t1, ... tm ] e1 ... em
   65    |
   66    |
   67    V
   68    case e1 of { T1# x1# ->
   69    ...
   70    case em of { Tm# xm# -> xm#
   71    ccall# foo [ r, t1#, ... tm# ] x1# ... xm#
   72    } ... }
   73 \end{verbatim}
   74 
   75 The reboxing of a @_ccall_@ result is a bit tricker: the types don't
   76 contain information about the state-pairing functions so we have to
   77 keep a list of \tr{(type, s-p-function)} pairs.  We transform as
   78 follows:
   79 \begin{verbatim}
   80    ccall# foo [ r, t1#, ... tm# ] e1# ... em#
   81    |
   82    |
   83    V
   84    \ s# -> case (ccall# foo [ r, t1#, ... tm# ] s# e1# ... em#) of
   85           (StateAnd<r># result# state#) -> (R# result#, realWorld#)
   86 \end{verbatim}
   87 -}
   88 
   89 dsCCall :: CLabelString -- C routine to invoke
   90         -> [CoreExpr]   -- Arguments (desugared)
   91         -- Precondition: none have representation-polymorphic types
   92         -> Safety       -- Safety of the call
   93         -> Type         -- Type of the result: IO t
   94         -> DsM CoreExpr -- Result, of type ???
   95 
   96 dsCCall lbl args may_gc result_ty
   97   = do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args
   98        (ccall_result_ty, res_wrapper) <- boxResult result_ty
   99        uniq <- newUnique
  100        dflags <- getDynFlags
  101        let
  102            target = StaticTarget NoSourceText lbl Nothing True
  103            the_fcall    = CCall (CCallSpec target CCallConv may_gc)
  104            the_prim_app = mkFCall dflags uniq the_fcall unboxed_args ccall_result_ty
  105        return (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
  106 
  107 mkFCall :: DynFlags -> Unique -> ForeignCall
  108         -> [CoreExpr]     -- Args
  109         -> Type           -- Result type
  110         -> CoreExpr
  111 -- Construct the ccall.  The only tricky bit is that the ccall Id should have
  112 -- no free vars, so if any of the arg tys do we must give it a polymorphic type.
  113 --      [I forget *why* it should have no free vars!]
  114 -- For example:
  115 --      mkCCall ... [s::StablePtr (a->b), x::Addr, c::Char]
  116 --
  117 -- Here we build a ccall thus
  118 --      (ccallid::(forall a b.  StablePtr (a -> b) -> Addr -> Char -> IO Addr))
  119 --                      a b s x c
  120 mkFCall dflags uniq the_fcall val_args res_ty
  121   = assert (all isTyVar tyvars) $ -- this must be true because the type is top-level
  122     mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args
  123   where
  124     arg_tys = map exprType val_args
  125     body_ty = (mkVisFunTysMany arg_tys res_ty)
  126     tyvars  = tyCoVarsOfTypeWellScoped body_ty
  127     ty      = mkInfForAllTys tyvars body_ty
  128     the_fcall_id = mkFCallId dflags uniq the_fcall ty
  129 
  130 unboxArg :: CoreExpr                    -- The supplied argument, not representation-polymorphic
  131          -> DsM (CoreExpr,              -- To pass as the actual argument
  132                  CoreExpr -> CoreExpr   -- Wrapper to unbox the arg
  133                 )
  134 -- Example: if the arg is e::Int, unboxArg will return
  135 --      (x#::Int#, \W. case x of I# x# -> W)
  136 -- where W is a CoreExpr that probably mentions x#
  137 
  138 -- always returns a non-representation-polymorphic expression
  139 
  140 unboxArg arg
  141   -- Primitive types: nothing to unbox
  142   | isPrimitiveType arg_ty
  143   = return (arg, \body -> body)
  144 
  145   -- Recursive newtypes
  146   | Just(co, _rep_ty) <- topNormaliseNewType_maybe arg_ty
  147   = unboxArg (mkCastDs arg co)
  148 
  149   -- Booleans
  150   | Just tc <- tyConAppTyCon_maybe arg_ty,
  151     tc `hasKey` boolTyConKey
  152   = do dflags <- getDynFlags
  153        let platform = targetPlatform dflags
  154        prim_arg <- newSysLocalDs Many intPrimTy
  155        return (Var prim_arg,
  156               \ body -> Case (mkIfThenElse arg (mkIntLit platform 1) (mkIntLit platform 0))
  157                              prim_arg
  158                              (exprType body)
  159                              [Alt DEFAULT [] body])
  160 
  161   -- Data types with a single constructor, which has a single, primitive-typed arg
  162   -- This deals with Int, Float etc; also Ptr, ForeignPtr
  163   | is_product_type && data_con_arity == 1
  164   = assertPpr (isUnliftedType data_con_arg_ty1) (pprType arg_ty) $
  165                         -- Typechecker ensures this
  166     do case_bndr <- newSysLocalDs Many arg_ty
  167        prim_arg <- newSysLocalDs Many data_con_arg_ty1
  168        return (Var prim_arg,
  169                \ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) [prim_arg] body]
  170               )
  171 
  172   -- Byte-arrays, both mutable and otherwise; hack warning
  173   -- We're looking for values of type ByteArray, MutableByteArray
  174   --    data ByteArray          ix = ByteArray        ix ix ByteArray#
  175   --    data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s)
  176   | is_product_type &&
  177     data_con_arity == 3 &&
  178     isJust maybe_arg3_tycon &&
  179     (arg3_tycon ==  byteArrayPrimTyCon ||
  180      arg3_tycon ==  mutableByteArrayPrimTyCon)
  181   = do case_bndr <- newSysLocalDs Many arg_ty
  182        vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs (map unrestricted data_con_arg_tys)
  183        return (Var arr_cts_var,
  184                \ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) vars body]
  185               )
  186 
  187   | otherwise
  188   = do l <- getSrcSpanDs
  189        pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
  190   where
  191     arg_ty                                      = exprType arg
  192     maybe_product_type                          = splitDataProductType_maybe arg_ty
  193     is_product_type                             = isJust maybe_product_type
  194     Just (_, _, data_con, scaled_data_con_arg_tys) = maybe_product_type
  195     data_con_arg_tys                            = map scaledThing scaled_data_con_arg_tys
  196     data_con_arity                              = dataConSourceArity data_con
  197     (data_con_arg_ty1 : _)                      = data_con_arg_tys
  198 
  199     (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys
  200     maybe_arg3_tycon               = tyConAppTyCon_maybe data_con_arg_ty3
  201     Just arg3_tycon                = maybe_arg3_tycon
  202 
  203 boxResult :: Type
  204           -> DsM (Type, CoreExpr -> CoreExpr)
  205 
  206 -- Takes the result of the user-level ccall:
  207 --      either (IO t),
  208 --      or maybe just t for a side-effect-free call
  209 -- Returns a wrapper for the primitive ccall itself, along with the
  210 -- type of the result of the primitive ccall.  This result type
  211 -- will be of the form
  212 --      State# RealWorld -> (# State# RealWorld, t' #)
  213 -- where t' is the unwrapped form of t.  If t is simply (), then
  214 -- the result type will be
  215 --      State# RealWorld -> (# State# RealWorld #)
  216 
  217 boxResult result_ty
  218   | Just (io_tycon, io_res_ty) <- tcSplitIOType_maybe result_ty
  219         -- isIOType_maybe handles the case where the type is a
  220         -- simple wrapping of IO.  E.g.
  221         --      newtype Wrap a = W (IO a)
  222         -- No coercion necessary because its a non-recursive newtype
  223         -- (If we wanted to handle a *recursive* newtype too, we'd need
  224         -- another case, and a coercion.)
  225         -- The result is IO t, so wrap the result in an IO constructor
  226   = do  { res <- resultWrapper io_res_ty
  227         ; let return_result state anss
  228                 = mkCoreUbxTup
  229                     [realWorldStatePrimTy, io_res_ty]
  230                     [state, anss]
  231 
  232         ; (ccall_res_ty, the_alt) <- mk_alt return_result res
  233 
  234         ; state_id <- newSysLocalDs Many realWorldStatePrimTy
  235         ; let io_data_con = head (tyConDataCons io_tycon)
  236               toIOCon     = dataConWrapId io_data_con
  237 
  238               wrap the_call =
  239                               mkApps (Var toIOCon)
  240                                      [ Type io_res_ty,
  241                                        Lam state_id $
  242                                        mkWildCase (App the_call (Var state_id))
  243                                              (unrestricted ccall_res_ty)
  244                                              (coreAltType the_alt)
  245                                              [the_alt]
  246                                      ]
  247 
  248         ; return (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap) }
  249 
  250 boxResult result_ty
  251   = do -- It isn't IO, so do unsafePerformIO
  252        -- It's not conveniently available, so we inline it
  253        res <- resultWrapper result_ty
  254        (ccall_res_ty, the_alt) <- mk_alt return_result res
  255        let
  256            wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId))
  257                                            (unrestricted ccall_res_ty)
  258                                            (coreAltType the_alt)
  259                                            [the_alt]
  260        return (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap)
  261   where
  262     return_result _ ans = ans
  263 
  264 
  265 mk_alt :: (Expr Var -> Expr Var -> Expr Var)
  266        -> (Maybe Type, Expr Var -> Expr Var)
  267        -> DsM (Type, CoreAlt)
  268 mk_alt return_result (Nothing, wrap_result)
  269   = do -- The ccall returns ()
  270        state_id <- newSysLocalDs Many realWorldStatePrimTy
  271        let
  272              the_rhs = return_result (Var state_id)
  273                                      (wrap_result (panic "boxResult"))
  274 
  275              ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy]
  276              the_alt      = Alt (DataAlt (tupleDataCon Unboxed 1)) [state_id] the_rhs
  277 
  278        return (ccall_res_ty, the_alt)
  279 
  280 mk_alt return_result (Just prim_res_ty, wrap_result)
  281   = -- The ccall returns a non-() value
  282     assertPpr (isPrimitiveType prim_res_ty) (ppr prim_res_ty) $
  283              -- True because resultWrapper ensures it is so
  284     do { result_id <- newSysLocalDs Many prim_res_ty
  285        ; state_id <- newSysLocalDs Many realWorldStatePrimTy
  286        ; let the_rhs = return_result (Var state_id)
  287                                 (wrap_result (Var result_id))
  288              ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty]
  289              the_alt      = Alt (DataAlt (tupleDataCon Unboxed 2)) [state_id, result_id] the_rhs
  290        ; return (ccall_res_ty, the_alt) }
  291 
  292 
  293 resultWrapper :: Type
  294               -> DsM (Maybe Type,               -- Type of the expected result, if any
  295                       CoreExpr -> CoreExpr)     -- Wrapper for the result
  296 -- resultWrapper deals with the result *value*
  297 -- E.g. foreign import foo :: Int -> IO T
  298 -- Then resultWrapper deals with marshalling the 'T' part
  299 -- So if    resultWrapper ty = (Just ty_rep, marshal)
  300 --  then      marshal (e :: ty_rep) :: ty
  301 -- That is, 'marshal' wrape the result returned by the foreign call,
  302 -- of type ty_rep, into the value Haskell expected, of type 'ty'
  303 --
  304 -- Invariant: ty_rep is always a primitive type
  305 --            i.e. (isPrimitiveType ty_rep) is True
  306 
  307 resultWrapper result_ty
  308   -- Base case 1: primitive types
  309   | isPrimitiveType result_ty
  310   = return (Just result_ty, \e -> e)
  311 
  312   -- Base case 2: the unit type ()
  313   | Just (tc,_) <- maybe_tc_app
  314   , tc `hasKey` unitTyConKey
  315   = return (Nothing, \_ -> unitExpr)
  316 
  317   -- Base case 3: the boolean type
  318   | Just (tc,_) <- maybe_tc_app
  319   , tc `hasKey` boolTyConKey
  320   = do { dflags <- getDynFlags
  321        ; let platform = targetPlatform dflags
  322        ; let marshal_bool e
  323                = mkWildCase e (unrestricted intPrimTy) boolTy
  324                    [ Alt DEFAULT                        [] (Var trueDataConId )
  325                    , Alt (LitAlt (mkLitInt platform 0)) [] (Var falseDataConId)]
  326        ; return (Just intPrimTy, marshal_bool) }
  327 
  328   -- Newtypes
  329   | Just (co, rep_ty) <- topNormaliseNewType_maybe result_ty
  330   = do { (maybe_ty, wrapper) <- resultWrapper rep_ty
  331        ; return (maybe_ty, \e -> mkCastDs (wrapper e) (mkSymCo co)) }
  332 
  333   -- The type might contain foralls (eg. for dummy type arguments,
  334   -- referring to 'Ptr a' is legal).
  335   | Just (tyvar, rest) <- splitForAllTyCoVar_maybe result_ty
  336   = do { (maybe_ty, wrapper) <- resultWrapper rest
  337        ; return (maybe_ty, \e -> Lam tyvar (wrapper e)) }
  338 
  339   -- Data types with a single constructor, which has a single arg
  340   -- This includes types like Ptr and ForeignPtr
  341   | Just (tycon, tycon_arg_tys) <- maybe_tc_app
  342   , Just data_con <- tyConSingleAlgDataCon_maybe tycon  -- One constructor
  343   , null (dataConExTyCoVars data_con)                   -- no existentials
  344   , [Scaled _ unwrapped_res_ty] <- dataConInstOrigArgTys data_con tycon_arg_tys  -- One argument
  345   = do { (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty
  346        ; let marshal_con e  = Var (dataConWrapId data_con)
  347                               `mkTyApps` tycon_arg_tys
  348                               `App` wrapper e
  349        ; return (maybe_ty, marshal_con) }
  350 
  351   | otherwise
  352   = pprPanic "resultWrapper" (ppr result_ty)
  353   where
  354     maybe_tc_app = splitTyConApp_maybe result_ty