summaryrefslogtreecommitdiff
path: root/compiler/deSugar/DsCCall.lhs
diff options
context:
space:
mode:
authorSimon Marlow <marlowsd@gmail.com>2009-07-27 14:45:24 +0000
committerSimon Marlow <marlowsd@gmail.com>2009-07-27 14:45:24 +0000
commit1fede4bc9501744bf2269ce2a4cb9fb735969caa (patch)
treef21e2178bcc90c3e1d50c2b0e93a68b7bfd369d4 /compiler/deSugar/DsCCall.lhs
parentdd849158c84941f5e3714dd4df24e467854f0d91 (diff)
downloadhaskell-1fede4bc9501744bf2269ce2a4cb9fb735969caa.tar.gz
Remove old 'foreign import dotnet' code
It still lives in darcs, if anyone wants to revive it sometime.
Diffstat (limited to 'compiler/deSugar/DsCCall.lhs')
-rw-r--r--compiler/deSugar/DsCCall.lhs25
1 files changed, 9 insertions, 16 deletions
diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs
index 27dff94839..0dd29c988f 100644
--- a/compiler/deSugar/DsCCall.lhs
+++ b/compiler/deSugar/DsCCall.lhs
@@ -88,7 +88,7 @@ dsCCall :: CLabelString -- C routine to invoke
dsCCall lbl args may_gc result_ty
= do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args
- (ccall_result_ty, res_wrapper) <- boxResult id Nothing result_ty
+ (ccall_result_ty, res_wrapper) <- boxResult result_ty
uniq <- newUnique
let
target = StaticTarget lbl
@@ -231,10 +231,7 @@ unboxArg arg
\begin{code}
-boxResult :: ((Maybe Type, CoreExpr -> CoreExpr)
- -> (Maybe Type, CoreExpr -> CoreExpr))
- -> Maybe Id
- -> Type
+boxResult :: Type
-> DsM (Type, CoreExpr -> CoreExpr)
-- Takes the result of the user-level ccall:
@@ -247,11 +244,8 @@ boxResult :: ((Maybe Type, CoreExpr -> CoreExpr)
-- where t' is the unwrapped form of t. If t is simply (), then
-- the result type will be
-- State# RealWorld -> (# State# RealWorld #)
---
--- The gruesome 'augment' and 'mbTopCon' are to do with .NET foreign calls
--- It looks a mess: I wonder if it could be refactored.
-boxResult augment mbTopCon result_ty
+boxResult result_ty
| Just (io_tycon, io_res_ty, co) <- tcSplitIOType_maybe result_ty
-- isIOType_maybe handles the case where the type is a
-- simple wrapping of IO. E.g.
@@ -261,9 +255,8 @@ boxResult augment mbTopCon result_ty
-- another case, and a coercion.)
-- The result is IO t, so wrap the result in an IO constructor
= do { res <- resultWrapper io_res_ty
- ; let aug_res = augment res
- extra_result_tys
- = case aug_res of
+ ; let extra_result_tys
+ = case res of
(Just ty,_)
| isUnboxedTupleType ty
-> let (Just (_, ls)) = splitTyConApp_maybe ty in tail ls
@@ -274,11 +267,11 @@ boxResult augment mbTopCon result_ty
(map Type (realWorldStatePrimTy : io_res_ty : extra_result_tys)
++ (state : anss))
- ; (ccall_res_ty, the_alt) <- mk_alt return_result aug_res
+ ; (ccall_res_ty, the_alt) <- mk_alt return_result res
; state_id <- newSysLocalDs realWorldStatePrimTy
; let io_data_con = head (tyConDataCons io_tycon)
- toIOCon = mbTopCon `orElse` dataConWrapId io_data_con
+ toIOCon = dataConWrapId io_data_con
wrap the_call = mkCoerceI (mkSymCoI co) $
mkApps (Var toIOCon)
@@ -292,11 +285,11 @@ boxResult augment mbTopCon result_ty
; return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) }
-boxResult augment _mbTopCon result_ty
+boxResult result_ty
= do -- It isn't IO, so do unsafePerformIO
-- It's not conveniently available, so we inline it
res <- resultWrapper result_ty
- (ccall_res_ty, the_alt) <- mk_alt return_result (augment res)
+ (ccall_res_ty, the_alt) <- mk_alt return_result res
let
wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId))
ccall_res_ty