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
47451553
Commit
47451553
authored
Jul 16, 2001
by
simonpj
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[project @ 2001-07-16 09:41:26 by simonpj]
Tidy up Type/TcType stuff in DsCCall/DsForeign
parent
4c3a6486
Changes
2
Hide whitespace changes
Inline
Side-by-side
Showing
2 changed files
with
34 additions
and
23 deletions
+34
-23
ghc/compiler/deSugar/DsCCall.lhs
ghc/compiler/deSugar/DsCCall.lhs
+10
-5
ghc/compiler/deSugar/DsForeign.lhs
ghc/compiler/deSugar/DsForeign.lhs
+24
-18
No files found.
ghc/compiler/deSugar/DsCCall.lhs
View file @
47451553
...
...
@@ -31,7 +31,7 @@ import TcType ( Type, isUnLiftedType, mkFunTys, mkFunTy,
isBoolTy, isUnitTy, isPrimitiveType,
tcSplitTyConApp_maybe
)
import Type (
splitTyConApp_maybe,
repType, eqType ) -- Sees the representation type
import Type ( repType, eqType ) -- Sees the representation type
import PrimOp ( PrimOp(TouchOp) )
import TysPrim ( realWorldStatePrimTy,
byteArrayPrimTyCon, mutableByteArrayPrimTyCon,
...
...
@@ -153,7 +153,6 @@ unboxArg arg
prim_arg
[(DEFAULT,[],body)])
-- Newtypes
-- Data types with a single constructor, which has a single, primitive-typed arg
-- This deals with Int, Float etc
| is_product_type && data_con_arity == 1
...
...
@@ -165,6 +164,9 @@ unboxArg arg
)
-- Byte-arrays, both mutable and otherwise; hack warning
-- We're looking for values of type ByteArray, MutableByteArray
-- data ByteArray ix = ByteArray ix ix ByteArray#
-- data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s)
| is_product_type &&
data_con_arity == 3 &&
maybeToBool maybe_arg3_tycon &&
...
...
@@ -183,7 +185,9 @@ unboxArg arg
where
arg_ty = repType (exprType arg)
-- The repType looks through any newtype or
-- implicit-parameter wrappings on the argument.
-- implicit-parameter wrappings on the argument;
-- this is necessary, because isBoolTy (in particular) does not.
maybe_product_type = splitProductType_maybe arg_ty
is_product_type = maybeToBool maybe_product_type
Just (_, _, data_con, data_con_arg_tys) = maybe_product_type
...
...
@@ -217,6 +221,8 @@ boxResult :: [Id] -> Type -> DsM (Type, CoreExpr -> CoreExpr)
boxResult arg_ids result_ty
= case tcSplitTyConApp_maybe result_ty of
-- This split absolutely has to be a tcSplit, because we must
-- see the IO type; and it's a newtype which is transparent to splitTyConApp.
-- The result is IO t, so wrap the result in an IO constructor
Just (io_tycon, [io_res_ty]) | io_tycon `hasKey` ioTyConKey
...
...
@@ -324,6 +330,5 @@ resultWrapper result_ty
| otherwise
= pprPanic "resultWrapper" (ppr result_ty)
where
result_ty_rep = repType result_ty
result_ty_rep = repType result_ty -- Look through any newtypes/implicit parameters
\end{code}
ghc/compiler/deSugar/DsForeign.lhs
View file @
47451553
...
...
@@ -28,14 +28,10 @@ import Name ( mkGlobalName, nameModule, nameOccName, getOccString,
NamedThing(..),
)
-- Import Type not TcType; in this module we are generating code
-- to marshal representation types across to C
import Type ( splitTyConApp_maybe, funResultTy,
splitFunTys, splitForAllTys, splitAppTy,
Type, mkFunTys, mkForAllTys, mkTyConApp,
mkFunTy, applyTy, eqType, repType
)
import TcType ( tcSplitForAllTys, tcSplitFunTys,
import Type ( repType, eqType )
import TcType ( Type, mkFunTys, mkForAllTys, mkTyConApp,
mkFunTy, applyTy,
tcSplitForAllTys, tcSplitFunTys, tcTyConAppArgs,
tcSplitTyConApp_maybe, tcSplitAppTy,
tcFunResultTy
)
...
...
@@ -151,6 +147,8 @@ dsFCall mod_Name fn_id fcall
ty = idType fn_id
(tvs, fun_ty) = tcSplitForAllTys ty
(arg_tys, io_res_ty) = tcSplitFunTys fun_ty
-- Must use tcSplit* functions because we want to
-- see that (IO t) in the corner
in
newSysLocalsDs arg_tys `thenDs` \ args ->
mapAndUnzipDs unboxArg (map Var args) `thenDs` \ (val_args, arg_wrappers) ->
...
...
@@ -225,6 +223,9 @@ dsFExport mod_name fn_id ty ext_name cconv isDyn
-- If it's IO t, return (\x.x, IO t, t)
-- If it's plain t, return (\x.returnIO x, IO t, t)
(case tcSplitTyConApp_maybe orig_res_ty of
-- We must use tcSplit here so that we see the (IO t) in
-- the type. [IO t is transparent to plain splitTyConApp.]
Just (ioTyCon, [res_ty])
-> ASSERT( ioTyCon `hasKey` ioTyConKey )
-- The function already returns IO t
...
...
@@ -303,15 +304,19 @@ dsFExport mod_name fn_id ty ext_name cconv isDyn
where
(tvs,sans_foralls) = tcSplitForAllTys ty
(fe_arg_tys', orig_res_ty) = tcSplitFunTys sans_foralls
(_, stbl_ptr_ty') = tcSplitForAllTys stbl_ptr_ty
(_, stbl_ptr_to_ty) = tcSplitAppTy stbl_ptr_ty'
-- We must use tcSplits here, because we want to see
-- the (IO t) in the corner of the type!
fe_arg_tys | isDyn = tail fe_arg_tys'
| otherwise = fe_arg_tys'
stbl_ptr_ty | isDyn = head fe_arg_tys'
| otherwise = error "stbl_ptr_ty"
(_, stbl_ptr_ty') = tcSplitForAllTys stbl_ptr_ty
(_, stbl_ptr_to_ty) = tcSplitAppTy stbl_ptr_ty'
-- Again, stable pointers are just newtypes,
-- so we must see them! Hence tcSplit*
\end{code}
@foreign export dynamic@ lets you dress up Haskell IO actions
...
...
@@ -395,11 +400,12 @@ dsFExportDynamic mod_name id cconv
returnDs ([fed, fe], h_code, c_code)
where
ty = idType id
(tvs,sans_foralls) = tcSplitForAllTys ty
([arg_ty], io_res_ty) = tcSplitFunTys sans_foralls
Just (ioTyCon, [res_ty]) = tcSplitTyConApp_maybe io_res_ty
export_ty = mkFunTy (mkTyConApp stablePtrTyCon [arg_ty]) arg_ty
ty = idType id
(tvs,sans_foralls) = tcSplitForAllTys ty
([arg_ty], io_res_ty) = tcSplitFunTys sans_foralls
[res_ty] = tcTyConAppArgs io_res_ty
-- Must use tcSplit* to see the (IO t), which is a newtype
export_ty = mkFunTy (mkTyConApp stablePtrTyCon [arg_ty]) arg_ty
toCName :: Id -> String
toCName i = showSDoc (pprCode CStyle (ppr (idName i)))
...
...
@@ -455,7 +461,7 @@ fexportEntry mod_nm c_nm helper args res_ty cc isDyn = (header_bits, c_bits)
cParamTypes = map showStgType real_args
res_ty_is_unit = res_ty `eqType` unitTy
res_ty_is_unit = res_ty `eqType` unitTy
-- Look through any newtypes
cResType | res_ty_is_unit = text "void"
| otherwise = showStgType res_ty
...
...
@@ -503,7 +509,7 @@ showStgType t = text "Hs" <> text (showFFIType t)
showFFIType :: Type -> String
showFFIType t = getOccString (getName tc)
where
tc = case
s
plitTyConApp_maybe (repType t) of
tc = case
tcS
plitTyConApp_maybe (repType t) of
Just (tc,_) -> tc
Nothing -> pprPanic "showFFIType" (ppr t)
\end{code}
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