Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
GHC
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Locked Files
Issues
4,332
Issues
4,332
List
Boards
Labels
Service Desk
Milestones
Iterations
Merge Requests
370
Merge Requests
370
Requirements
Requirements
List
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Security & Compliance
Security & Compliance
Dependency List
License Compliance
Operations
Operations
Incidents
Environments
Analytics
Analytics
CI / CD
Code Review
Insights
Issue
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
b601e528
Commit
b601e528
authored
Jan 17, 2008
by
twanvl
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Monadify deSugar/DsCCall: use do, return, applicative, standard monad functions
parent
682cf829
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
with
122 additions
and
129 deletions
+122
-129
compiler/deSugar/DsCCall.lhs
compiler/deSugar/DsCCall.lhs
+122
-129
No files found.
compiler/deSugar/DsCCall.lhs
View file @
b601e528
...
...
@@ -98,15 +98,14 @@ dsCCall :: CLabelString -- C routine to invoke
-> DsM CoreExpr -- Result, of type ???
dsCCall lbl args may_gc result_ty
= mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) ->
boxResult id Nothing result_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
newUnique `thenDs` \ uniq ->
let
target = StaticTarget lbl
the_fcall = CCall (CCallSpec target CCallConv may_gc)
the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty
in
returnDs (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
= do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args
(ccall_result_ty, res_wrapper) <- boxResult id Nothing result_ty
uniq <- newUnique
let
target = StaticTarget lbl
the_fcall = CCall (CCallSpec target CCallConv may_gc)
the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty
return (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
mkFCall :: Unique -> ForeignCall
-> [CoreExpr] -- Args
...
...
@@ -143,7 +142,7 @@ unboxArg :: CoreExpr -- The supplied argument
unboxArg arg
-- Primtive types: nothing to unbox
| isPrimitiveType arg_ty
= return
Ds
(arg, \body -> body)
= return (arg, \body -> body)
-- Recursive newtypes
| Just(rep_ty, co) <- splitNewTypeRepCo_maybe arg_ty
...
...
@@ -152,26 +151,26 @@ unboxArg arg
-- Booleans
| Just (tc,_) <- splitTyConApp_maybe arg_ty,
tc `hasKey` boolTyConKey
=
newSysLocalDs intPrimTy `thenDs` \ prim_arg ->
returnDs
(Var prim_arg,
\ body -> Case (Case arg (mkWildId arg_ty) intPrimTy
[(DataAlt falseDataCon,[],mkIntLit 0),
(DataAlt trueDataCon, [],mkIntLit 1)])
-- In increasing tag order!
=
do prim_arg <- newSysLocalDs intPrimTy
return
(Var prim_arg,
\ body -> Case (Case arg (mkWildId arg_ty) intPrimTy
[(DataAlt falseDataCon,[],mkIntLit 0),
(DataAlt trueDataCon, [],mkIntLit 1)])
-- In increasing tag order!
prim_arg
(exprType body)
[(DEFAULT,[],body)])
[(DEFAULT,[],body)])
-- Data types with a single constructor, which has a single, primitive-typed arg
-- This deals with Int, Float etc; also Ptr, ForeignPtr
| is_product_type && data_con_arity == 1
= ASSERT2(isUnLiftedType data_con_arg_ty1, pprType arg_ty)
-- Typechecker ensures this
newSysLocalDs arg_ty `thenDs` \ case_bndr ->
newSysLocalDs data_con_arg_ty1 `thenDs` \ prim_arg ->
returnDs
(Var prim_arg,
\ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)]
)
-- Typechecker ensures this
do case_bndr <- newSysLocalDs arg_ty
prim_arg <- newSysLocalDs data_con_arg_ty1
return
(Var prim_arg,
\ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)]
)
-- Byte-arrays, both mutable and otherwise; hack warning
-- We're looking for values of type ByteArray, MutableByteArray
...
...
@@ -182,12 +181,11 @@ unboxArg arg
maybeToBool maybe_arg3_tycon &&
(arg3_tycon == byteArrayPrimTyCon ||
arg3_tycon == mutableByteArrayPrimTyCon)
= newSysLocalDs arg_ty `thenDs` \ case_bndr ->
newSysLocalsDs data_con_arg_tys `thenDs` \ vars@[l_var, r_var, arr_cts_var] ->
returnDs (Var arr_cts_var,
\ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)]
)
= do case_bndr <- newSysLocalDs arg_ty
vars@[l_var, r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys
return (Var arr_cts_var,
\ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)]
)
----- Cases for .NET; almost certainly bit-rotted ---------
| Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty,
...
...
@@ -195,40 +193,40 @@ unboxArg arg
Just (cc,[]) <- splitTyConApp_maybe arg_ty,
cc == charTyCon
-- String; dotnet only
= d
sLookupGlobalId marshalStringName `thenDs` \ unpack_id ->
newSysLocalDs addrPrimTy `thenDs` \ prim_string ->
returnDs
(Var prim_string,
\ body ->
let
io_ty = exprType body
Just (_,io_arg,_) = tcSplitIOType_maybe io_ty
in
mkApps (Var unpack_id)
[ Type io_arg
, arg
, Lam prim_string body
])
= d
o unpack_id <- dsLookupGlobalId marshalStringName
prim_string <- newSysLocalDs addrPrimTy
return
(Var prim_string,
\ body ->
let
io_ty = exprType body
Just (_,io_arg,_) = tcSplitIOType_maybe io_ty
in
mkApps (Var unpack_id)
[ Type io_arg
, arg
, Lam prim_string body
])
| Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty,
tyConName tc == objectTyConName
-- Object; dotnet only
= d
sLookupGlobalId marshalObjectName `thenDs` \ unpack_id ->
newSysLocalDs addrPrimTy `thenDs` \ prim_obj ->
returnDs
(Var prim_obj,
\ body ->
let
io_ty = exprType body
Just (_,io_arg,_) = tcSplitIOType_maybe io_ty
in
mkApps (Var unpack_id)
[ Type io_arg
, arg
, Lam prim_obj body
])
= d
o unpack_id <- dsLookupGlobalId marshalObjectName
prim_obj <- newSysLocalDs addrPrimTy
return
(Var prim_obj,
\ body ->
let
io_ty = exprType body
Just (_,io_arg,_) = tcSplitIOType_maybe io_ty
in
mkApps (Var unpack_id)
[ Type io_arg
, arg
, Lam prim_obj body
])
--------------- End of cases for .NET --------------------
| otherwise
=
getSrcSpanDs `thenDs` \ l ->
pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
=
do l <- getSrcSpanDs
pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
where
arg_ty = exprType arg
maybe_product_type = splitProductType_maybe arg_ty
...
...
@@ -306,127 +304,122 @@ boxResult augment mbTopCon result_ty
; return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) }
boxResult augment mbTopCon result_ty
= -- It isn't IO, so do unsafePerformIO
-- It's not conveniently available, so we inline it
resultWrapper result_ty `thenDs` \ res ->
mk_alt return_result (augment res) `thenDs` \ (ccall_res_ty, the_alt) ->
let
wrap = \ the_call -> Case (App the_call (Var realWorldPrimId))
(mkWildId ccall_res_ty)
(coreAltType the_alt)
[the_alt]
in
returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
= 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)
let
wrap = \ the_call -> Case (App the_call (Var realWorldPrimId))
(mkWildId ccall_res_ty)
(coreAltType the_alt)
[the_alt]
return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
where
return_result state [ans] = ans
return_result _ _ = panic "return_result: expected single result"
mk_alt return_result (Nothing, wrap_result)
=
-- The ccall returns ()
newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
let
the_rhs = return_result (Var state_id)
[wrap_result (panic "boxResult")]
=
do
-- The ccall returns ()
state_id <- newSysLocalDs realWorldStatePrimTy
let
the_rhs = return_result (Var state_id)
[wrap_result (panic "boxResult")]
ccall_res_ty = mkTyConApp unboxedSingletonTyCon [realWorldStatePrimTy]
the_alt = (DataAlt unboxedSingletonDataCon, [state_id], the_rhs)
in
returnDs
(ccall_res_ty, the_alt)
ccall_res_ty = mkTyConApp unboxedSingletonTyCon [realWorldStatePrimTy]
the_alt = (DataAlt unboxedSingletonDataCon, [state_id], the_rhs)
return
(ccall_res_ty, the_alt)
mk_alt return_result (Just prim_res_ty, wrap_result)
-- The ccall returns a non-() value
| isUnboxedTupleType prim_res_ty
= let
Just (_, ls) = splitTyConApp_maybe prim_res_ty
arity = 1 + length ls
in
mappM newSysLocalDs ls `thenDs` \ args_ids@(result_id:as) ->
newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
| isUnboxedTupleType prim_res_ty= do
let
the_rhs = return_result (Var state_id)
(wrap_result (Var result_id) : map Var as)
ccall_res_ty = mkTyConApp (tupleTyCon Unboxed arity)
(realWorldStatePrimTy : ls)
the_alt = ( DataAlt (tupleCon Unboxed arity)
, (state_id : args_ids)
, the_rhs
)
in
returnDs (ccall_res_ty, the_alt)
| otherwise
= newSysLocalDs prim_res_ty `thenDs` \ result_id ->
newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
Just (_, ls) = splitTyConApp_maybe prim_res_ty
arity = 1 + length ls
args_ids@(result_id:as) <- mapM newSysLocalDs ls
state_id <- newSysLocalDs realWorldStatePrimTy
let
the_rhs = return_result (Var state_id)
(wrap_result (Var result_id) : map Var as)
ccall_res_ty = mkTyConApp (tupleTyCon Unboxed arity)
(realWorldStatePrimTy : ls)
the_alt = ( DataAlt (tupleCon Unboxed arity)
, (state_id : args_ids)
, the_rhs
)
return (ccall_res_ty, the_alt)
| otherwise = do
result_id <- newSysLocalDs prim_res_ty
state_id <- newSysLocalDs realWorldStatePrimTy
let
the_rhs = return_result (Var state_id)
[wrap_result (Var result_id)]
ccall_res_ty = mkTyConApp unboxedPairTyCon [realWorldStatePrimTy, prim_res_ty]
the_alt = (DataAlt unboxedPairDataCon, [state_id, result_id], the_rhs)
in
returnDs (ccall_res_ty, the_alt)
the_rhs = return_result (Var state_id)
[wrap_result (Var result_id)]
ccall_res_ty = mkTyConApp unboxedPairTyCon [realWorldStatePrimTy, prim_res_ty]
the_alt = (DataAlt unboxedPairDataCon, [state_id, result_id], the_rhs)
return (ccall_res_ty, the_alt)
resultWrapper :: Type
-> DsM (Maybe Type,
-- Type of the expected result, if any
CoreExpr -> CoreExpr)
-- Wrapper for the result
-> DsM (Maybe Type,
-- Type of the expected result, if any
CoreExpr -> CoreExpr)
-- Wrapper for the result
-- resultWrapper deals with the result *value*
-- E.g. foreign import foo :: Int -> IO T
-- Then resultWrapper deals with marshalling the 'T' part
resultWrapper result_ty
-- Base case 1: primitive types
| isPrimitiveType result_ty
= return
Ds
(Just result_ty, \e -> e)
= return (Just result_ty, \e -> e)
-- Base case 2: the unit type ()
| Just (tc,_) <- maybe_tc_app, tc `hasKey` unitTyConKey
= return
Ds
(Nothing, \e -> Var unitDataConId)
= return (Nothing, \e -> Var unitDataConId)
-- Base case 3: the boolean type
| Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey
= return
Ds
= return
(Just intPrimTy, \e -> Case e (mkWildId intPrimTy)
boolTy
[(DEFAULT ,[],Var trueDataConId ),
(LitAlt (mkMachInt 0),[],Var falseDataConId)])
[(DEFAULT ,[],Var trueDataConId ),
(LitAlt (mkMachInt 0),[],Var falseDataConId)])
-- Recursive newtypes
| Just (rep_ty, co) <- splitNewTypeRepCo_maybe result_ty
=
resultWrapper rep_ty `thenDs` \ (maybe_ty, wrapper) ->
returnDs
(maybe_ty, \e -> mkCoerce (mkSymCoercion co) (wrapper e))
=
do (maybe_ty, wrapper) <- resultWrapper rep_ty
return
(maybe_ty, \e -> mkCoerce (mkSymCoercion co) (wrapper e))
-- The type might contain foralls (eg. for dummy type arguments,
-- referring to 'Ptr a' is legal).
| Just (tyvar, rest) <- splitForAllTy_maybe result_ty
=
resultWrapper rest `thenDs` \ (maybe_ty, wrapper) ->
returnDs
(maybe_ty, \e -> Lam tyvar (wrapper e))
=
do (maybe_ty, wrapper) <- resultWrapper rest
return
(maybe_ty, \e -> Lam tyvar (wrapper e))
-- Data types with a single constructor, which has a single arg
-- This includes types like Ptr and ForeignPtr
| Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitProductType_maybe result_ty,
dataConSourceArity data_con == 1
= let
(unwrapped_res_ty : _) = data_con_arg_tys
narrow_wrapper = maybeNarrow tycon
in
resultWrapper unwrapped_res_ty `thenDs` \ (maybe_ty, wrapper) ->
returnDs
(maybe_ty, \e -> mkApps (Var (dataConWrapId data_con))
(map Type tycon_arg_tys ++ [wrapper (narrow_wrapper e)]))
= do let
(unwrapped_res_ty : _) = data_con_arg_tys
narrow_wrapper = maybeNarrow tycon
(maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty
return
(maybe_ty, \e -> mkApps (Var (dataConWrapId data_con))
(map Type tycon_arg_tys ++ [wrapper (narrow_wrapper e)]))
-- Strings; 'dotnet' only.
| Just (tc, [arg_ty]) <- maybe_tc_app, tc == listTyCon,
Just (cc,[]) <- splitTyConApp_maybe arg_ty, cc == charTyCon
= d
sLookupGlobalId unmarshalStringName `thenDs` \ pack_id ->
returnDs
(Just addrPrimTy,
\ e -> App (Var pack_id) e)
= d
o pack_id <- dsLookupGlobalId unmarshalStringName
return
(Just addrPrimTy,
\ e -> App (Var pack_id) e)
-- Objects; 'dotnet' only.
| Just (tc, [arg_ty]) <- maybe_tc_app,
tyConName tc == objectTyConName
= d
sLookupGlobalId unmarshalObjectName `thenDs` \ pack_id ->
returnDs
(Just addrPrimTy,
\ e -> App (Var pack_id) e)
= d
o pack_id <- dsLookupGlobalId unmarshalObjectName
return
(Just addrPrimTy,
\ e -> App (Var pack_id) e)
| otherwise
= pprPanic "resultWrapper" (ppr result_ty)
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment