Commit d4e0a55c authored by simonpj's avatar simonpj

[project @ 2000-04-05 16:25:51 by simonpj]

* Add new flag -fddump-minimal-imports, which dumps a file
  M.imports that contains the (allegedly) minimal bunch of
  imports that make the system work.
  It's done by Rename.printMinimalImports

* Extend foreign import/export to handle
	* Booleans
	* newtypes
  as requested by the FFI team

* Tidy up DsCCall quite a bit
  Remove maybeBoxedPrimTy from TcHsSyn
parent 90515a13
......@@ -45,7 +45,8 @@ import TyCon ( tyConDataCons )
import Name ( NamedThing(..) )
import DataCon ( DataCon{-instance NamedThing-}, dataConWrapId )
import Maybes ( maybeToBool, catMaybes )
import PrimOp ( primOpNeedsWrapper, pprPrimOp, PrimOp(..), CCall(..), CCallTarget(..) )
import PrimOp ( primOpNeedsWrapper, pprPrimOp, pprCCallOp,
PrimOp(..), CCall(..), CCallTarget(..) )
import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize, showPrimRep )
import SMRep ( pprSMRep )
import Unique ( pprUnique, Unique{-instance NamedThing-} )
......@@ -777,7 +778,7 @@ Amendment to the above: if we can GC, we have to:
that the runtime check that PerformGC is being used sensibly will work.
\begin{code}
pprCCall (CCall op_str is_asm may_gc cconv) args results vol_regs
pprCCall call@(CCall op_str is_asm may_gc cconv) args results vol_regs
= vcat [
char '{',
declare_local_vars, -- local var for *result*
......@@ -797,10 +798,10 @@ pprCCall (CCall op_str is_asm may_gc cconv) args results vol_regs
| otherwise = ( pp_basic_saves $$ pp_saves,
pp_basic_restores $$ pp_restores)
non_void_args =
let nvas = tail args
in ASSERT (all non_void nvas) nvas
-- the first argument will be the "I/O world" token (a VoidRep)
non_void_args = let nvas = take (length args - 1) args
in ASSERT2 ( all non_void nvas, pprCCallOp call <+> hsep (map pprAmode args) )
nvas
-- the last argument will be the "I/O world" token (a VoidRep)
-- all others should be non-void
non_void_results =
......
......@@ -43,7 +43,7 @@ import Rules ( addRule )
import Type ( Type, ClassContext, mkDictTy, mkTyConApp, mkTyVarTys,
mkFunTys, mkFunTy, mkSigmaTy, classesToPreds,
isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType, tyVarsOfTypes,
splitSigmaTy, splitFunTy_maybe, splitAlgTyConApp,
splitSigmaTy, splitFunTy_maybe,
splitFunTys, splitForAllTys, unUsgTy,
mkUsgTy, UsageAnn(..)
)
......
......@@ -23,8 +23,9 @@ module Name (
tidyTopName,
nameOccName, nameModule, setNameOcc, nameRdrName, setNameModule,
isUserExportedName, isUserImportedName, isUserImportedExplicitlyName, nameSrcLoc,
isLocallyDefinedName, isDynName,
isUserExportedName, isUserImportedName, isUserImportedExplicitlyName,
maybeUserImportedFrom,
nameSrcLoc, isLocallyDefinedName, isDynName,
isSystemName, isLocalName, isGlobalName, isExternallyVisibleName,
......@@ -431,6 +432,9 @@ isUserImportedExplicitlyName other = False
isUserImportedName (Name { n_prov = NonLocalDef (UserImport _ _ _) _ }) = True
isUserImportedName other = False
maybeUserImportedFrom (Name { n_prov = NonLocalDef (UserImport m _ _) _ }) = Just m
maybeUserImportedFrom other = Nothing
isDynName :: Name -> Bool
-- Does this name come from a DLL?
isDynName nm = not (isLocallyDefinedName nm) &&
......
%
% (c) The GRASP Project, Glasgow University, 1992-1998
%
% $Id: CgRetConv.lhs,v 1.20 2000/03/23 17:45:19 simonpj Exp $
% $Id: CgRetConv.lhs,v 1.21 2000/04/05 16:25:51 simonpj Exp $
%
\section[CgRetConv]{Return conventions for the code generator}
......@@ -31,8 +31,7 @@ import DataCon ( DataCon )
import PrimOp ( PrimOp{-instance Outputable-} )
import PrimRep ( isFloatingRep, PrimRep(..), is64BitRep )
import TyCon ( TyCon, tyConDataCons, tyConFamilySize )
import Type ( Type, typePrimRep, isUnLiftedType,
splitAlgTyConApp_maybe )
import Type ( Type, typePrimRep, isUnLiftedType )
import Util ( isn'tIn )
import Outputable
......
......@@ -36,7 +36,6 @@ import Type ( Type, Kind, tyVarsOfType,
splitFunTy_maybe, mkPiType, mkTyVarTy, unUsgTy,
splitForAllTy_maybe, splitTyConApp_maybe,
isUnLiftedType, typeKind,
splitAlgTyConApp_maybe,
isUnboxedTupleType,
hasMoreBoxityInfo
)
......
......@@ -56,7 +56,7 @@ import Literal ( isLitLitLit )
import PrimOp ( PrimOp(..), primOpIsDupable, primOpOutOfLine, ccallIsCasm )
import IdInfo ( ArityInfo(..), InlinePragInfo(..), OccInfo(..), IdFlavour(..), CprInfo(..), insideLam, workerExists )
import TyCon ( tyConFamilySize )
import Type ( splitAlgTyConApp_maybe, splitFunTy_maybe, isUnLiftedType )
import Type ( splitFunTy_maybe, isUnLiftedType )
import Unique ( Unique, buildIdKey, augmentIdKey )
import Maybes ( maybeToBool )
import Bag
......
......@@ -159,9 +159,7 @@ mkInlineMe e | exprIsTrivial e = e
\begin{code}
mkCoerce :: Type -> Type -> Expr b -> Expr b
-- In (mkCoerce to_ty from_ty e), we require that from_ty = exprType e
-- But exprType is defined in CoreUtils, so we don't check the assertion
mkCoerce :: Type -> Type -> CoreExpr -> CoreExpr
mkCoerce to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
= ASSERT( from_ty == to_ty2 )
......@@ -169,7 +167,8 @@ mkCoerce to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
mkCoerce to_ty from_ty expr
| to_ty == from_ty = expr
| otherwise = Note (Coerce to_ty from_ty) expr
| otherwise = ASSERT( from_ty == exprType expr )
Note (Coerce to_ty from_ty) expr
\end{code}
\begin{code}
......
......@@ -9,9 +9,7 @@ module DsCCall
, mkCCall
, unboxArg
, boxResult
, wrapUnboxedValue
, can'tSeeDataConsPanic
, resultWrapper
) where
#include "HsVersions.h"
......@@ -21,31 +19,31 @@ import CoreSyn
import DsMonad
import DsUtils
import TcHsSyn ( maybeBoxedPrimType )
import CoreUtils ( exprType )
import CoreUtils ( exprType, mkCoerce )
import Id ( Id, mkWildId )
import MkId ( mkCCallOpId )
import MkId ( mkCCallOpId, realWorldPrimId )
import Maybes ( maybeToBool )
import PrelInfo ( packStringForCId )
import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..) )
import DataCon ( DataCon, splitProductType_maybe )
import DataCon ( DataCon, splitProductType_maybe, dataConSourceArity, dataConWrapId )
import CallConv
import Type ( isUnLiftedType, splitAlgTyConApp_maybe, mkFunTys,
splitTyConApp_maybe, tyVarsOfType, mkForAllTys, Type
splitTyConApp_maybe, tyVarsOfType, mkForAllTys,
isNewType, repType, isUnLiftedType, mkFunTy,
Type
)
import TysPrim ( byteArrayPrimTy, realWorldStatePrimTy,
byteArrayPrimTyCon, mutableByteArrayPrimTyCon,
intPrimTy
byteArrayPrimTyCon, mutableByteArrayPrimTyCon, intPrimTy
)
import TysWiredIn ( unitDataConId, stringTy, boolTy,
falseDataCon, falseDataConId,
trueDataCon, trueDataConId,
import TysWiredIn ( unitDataConId, stringTy,
unboxedPairDataCon,
mkUnboxedTupleTy, unboxedTupleCon
mkUnboxedTupleTy, unboxedTupleCon,
boolTy, trueDataCon, falseDataCon, trueDataConId, falseDataConId,
unitTy
)
import Literal ( mkMachInt )
import CStrings ( CLabelString )
import Unique ( Unique )
import Unique ( Unique, Uniquable(..), ioTyConKey )
import VarSet ( varSetElems )
import Outputable
\end{code}
......@@ -90,22 +88,18 @@ dsCCall :: CLabelString -- C routine to invoke
-> [CoreExpr] -- Arguments (desugared)
-> Bool -- True <=> might cause Haskell GC
-> Bool -- True <=> really a "_casm_"
-> Type -- Type of the result (a boxed-prim IO type)
-> Type -- Type of the result: IO t
-> DsM CoreExpr
dsCCall lbl args may_gc is_asm result_ty
= newSysLocalDs realWorldStatePrimTy `thenDs` \ old_s ->
mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) ->
boxResult result_ty `thenDs` \ (final_result_ty, res_wrapper) ->
= mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) ->
boxResult result_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
getUniqueDs `thenDs` \ uniq ->
let
val_args = Var old_s : unboxed_args
the_ccall = CCall (StaticTarget lbl) is_asm may_gc cCallConv
the_prim_app = mkCCall uniq the_ccall val_args final_result_ty
the_body = foldr ($) (res_wrapper the_prim_app) arg_wrappers
the_prim_app = mkCCall uniq the_ccall unboxed_args ccall_result_ty
in
returnDs (Lam old_s the_body)
returnDs (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
mkCCall :: Unique -> CCall
-> [CoreExpr] -- Args
......@@ -135,32 +129,42 @@ unboxArg :: CoreExpr -- The supplied argument
-> DsM (CoreExpr, -- To pass as the actual argument
CoreExpr -> CoreExpr -- Wrapper to unbox the arg
)
unboxArg arg
-- Example: if the arg is e::Int, unboxArg will return
-- (x#::Int#, \W. case x of I# x# -> W)
-- where W is a CoreExpr that probably mentions x#
-- Primitive types
-- ADR Question: can this ever be used? None of the PrimTypes are
-- instances of the CCallable class.
--
-- SOF response:
-- Oh yes they are, I've just added them :-) Having _ccall_ and _casm_
-- that accept unboxed arguments is a Good Thing if you have a stub generator
-- which generates the boiler-plate box-unbox code for you, i.e., it may help
-- us nuke this very module :-)
--
unboxArg arg
-- Unlifted types: nothing to unbox
| isUnLiftedType arg_ty
= returnDs (arg, \body -> body)
-- Strings
| arg_ty == stringTy
-- ToDo (ADR): - allow synonyms of Strings too?
= newSysLocalDs byteArrayPrimTy `thenDs` \ prim_arg ->
-- Newtypes
| isNewType arg_ty
= unboxArg (mkCoerce (repType arg_ty) arg_ty arg)
-- Booleans
| arg_ty == boolTy
= newSysLocalDs intPrimTy `thenDs` \ prim_arg ->
returnDs (Var prim_arg,
\body -> Case (App (Var packStringForCId) arg)
prim_arg [(DEFAULT,[],body)])
\ body -> Case (Case arg (mkWildId arg_ty)
[(DataAlt falseDataCon,[],mkIntLit 0),
(DataAlt trueDataCon, [],mkIntLit 1)])
prim_arg
[(DEFAULT,[],body)])
-- 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
= ASSERT(isUnLiftedType data_con_arg_ty1 ) -- 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 [(DataAlt data_con,[prim_arg],body)]
)
-- Byte-arrays, both mutable and otherwise; hack warning
| is_product_type &&
length data_con_arg_tys == 3 &&
data_con_arity == 3 &&
maybeToBool maybe_arg3_tycon &&
(arg3_tycon == byteArrayPrimTyCon ||
arg3_tycon == mutableByteArrayPrimTyCon)
......@@ -171,141 +175,134 @@ unboxArg arg
\ body -> Case arg case_bndr [(DataAlt data_con,vars,body)]
)
-- Data types with a single constructor, which has a single, primitive-typed arg
| maybeToBool maybe_boxed_prim_arg_ty
= newSysLocalDs arg_ty `thenDs` \ case_bndr ->
newSysLocalDs the_prim_arg_ty `thenDs` \ prim_arg ->
returnDs (Var prim_arg,
\ body -> Case arg case_bndr [(DataAlt box_data_con,[prim_arg],body)]
)
-- Booleans
| arg_ty == boolTy
= newSysLocalDs intPrimTy `thenDs` \ prim_arg ->
returnDs (Var prim_arg,
\ body -> Case (Case arg (mkWildId arg_ty) [
(DataAlt falseDataCon,[],mkIntLit 0),
(DataAlt trueDataCon, [],mkIntLit 1)])
prim_arg [(DEFAULT,[],body)]
)
| otherwise
= getSrcLocDs `thenDs` \ l ->
pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
where
arg_ty = exprType arg
maybe_boxed_prim_arg_ty = maybeBoxedPrimType arg_ty
(Just (box_data_con, the_prim_arg_ty)) = maybe_boxed_prim_arg_ty
arg_ty = exprType arg
arg_rep_ty = repType arg_ty
maybe_product_type = splitProductType_maybe arg_ty
is_product_type = maybeToBool maybe_product_type
Just (tycon, _, data_con, data_con_arg_tys) = maybe_product_type
(data_con_arg_ty1 : data_con_arg_ty2 : data_con_arg_ty3 :_)
= data_con_arg_tys
maybe_arg3_tycon = splitTyConApp_maybe data_con_arg_ty3
Just (arg3_tycon,_) = maybe_arg3_tycon
data_con_arity = dataConSourceArity data_con
(data_con_arg_ty1 : _) = data_con_arg_tys
can'tSeeDataConsPanic thing ty
= pprPanic
"ERROR: Can't see the data constructor(s) for _ccall_/_casm_/foreign declaration"
(hcat [ text thing, text "; type: ", ppr ty
, text "(try compiling with -fno-prune-tydecls ..)\n"])
(_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys
maybe_arg3_tycon = splitTyConApp_maybe data_con_arg_ty3
Just (arg3_tycon,_) = maybe_arg3_tycon
\end{code}
\begin{code}
boxResult :: Type -- Type of desired result
-> DsM (Type, -- Type of the result of the ccall itself
CoreExpr -> CoreExpr) -- Wrapper for the ccall
-- to box the result
boxResult result_ty
-- Data types with a single nullary constructor
| (maybeToBool maybe_product_type) && -- Data type
(null data_con_arg_tys)
=
newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id ->
{-
wrapUnboxedValue result_ty `thenDs` \ (state_and_prim_datacon,
state_and_prim_ty, prim_result_id, the_result) ->
mkConDs ioOkDataCon
[TyArg result_ty, VarArg (Var prim_state_id), VarArg the_result]
`thenDs` \ the_pair ->
-}
let
the_pair = mkConApp unboxedPairDataCon
[Type realWorldStatePrimTy, Type result_ty,
Var prim_state_id,
Var unitDataConId]
the_alt = (DataAlt (unboxedTupleCon 1), [prim_state_id], the_pair)
scrut_ty = mkUnboxedTupleTy 1 [realWorldStatePrimTy]
in
returnDs (scrut_ty, \prim_app -> Case prim_app (mkWildId scrut_ty) [the_alt]
)
boxResult :: Type -> DsM (Type, CoreExpr -> CoreExpr)
-- Takes the result of the user-level ccall:
-- either (IO t),
-- or maybe just t for an side-effect-free call
-- Returns a wrapper for the primitive ccall itself, along with the
-- type of the result of the primitive ccall. This result type
-- will be of the form
-- State# RealWorld -> (# State# RealWorld, t' #)
-- where t' is the unwrapped form of t. If t is simply (), then
-- the result type will be
-- State# RealWorld -> (# State# RealWorld #)
-- Data types with a single constructor, which has a single, primitive-typed arg
| (maybeToBool maybe_product_type) && -- Data type
not (null data_con_arg_tys) && null other_args_tys && -- Just one arg
isUnLiftedType the_prim_result_ty -- of primitive type
=
newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id ->
newSysLocalDs the_prim_result_ty `thenDs` \ prim_result_id ->
newSysLocalDs ccall_res_type `thenDs` \ case_bndr ->
let
the_result = mkConApp data_con (map Type tycon_arg_tys ++ [Var prim_result_id])
the_pair = mkConApp unboxedPairDataCon
[Type realWorldStatePrimTy, Type result_ty,
Var prim_state_id, the_result]
the_alt = (DataAlt unboxedPairDataCon, [prim_state_id, prim_result_id], the_pair)
in
returnDs (ccall_res_type, \prim_app -> Case prim_app case_bndr [the_alt]
)
boxResult result_ty
= case splitAlgTyConApp_maybe result_ty of
-- The result is IO t, so wrap the result in an IO constructor
Just (io_tycon, [io_res_ty], [io_data_con]) | getUnique io_tycon == ioTyConKey
-> mk_alt return_result
(resultWrapper io_res_ty) `thenDs` \ (ccall_res_ty, the_alt) ->
newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
let
wrap = \ the_call -> mkApps (Var (dataConWrapId io_data_con))
[Type io_res_ty, Lam state_id $
Case (App the_call (Var state_id))
(mkWildId ccall_res_ty)
[the_alt]]
in
returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
where
return_result state ans = mkConApp unboxedPairDataCon
[Type realWorldStatePrimTy, Type io_res_ty,
state, ans]
-- It isn't, so do unsafePerformIO
-- It's not conveniently available, so we inline it
other -> mk_alt return_result
(resultWrapper result_ty) `thenDs` \ (ccall_res_ty, the_alt) ->
let
wrap = \ the_call -> Case (App the_call (Var realWorldPrimId))
(mkWildId ccall_res_ty)
[the_alt]
in
returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
where
return_result state ans = ans
where
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"))
ccall_res_ty = mkUnboxedTupleTy 1 [realWorldStatePrimTy]
the_alt = (DataAlt (unboxedTupleCon 1), [state_id], the_rhs)
in
returnDs (ccall_res_ty, the_alt)
mk_alt return_result (Just prim_res_ty, wrap_result)
= -- The ccall returns a non-() value
newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
newSysLocalDs prim_res_ty `thenDs` \ result_id ->
let
the_rhs = return_result (Var state_id) (wrap_result (Var result_id))
ccall_res_ty = mkUnboxedTupleTy 2 [realWorldStatePrimTy, prim_res_ty]
the_alt = (DataAlt unboxedPairDataCon, [state_id, result_id], the_rhs)
in
returnDs (ccall_res_ty, the_alt)
resultWrapper :: Type
-> (Maybe Type, -- Type of the expected result, if any
CoreExpr -> CoreExpr) -- Wrapper for the result
resultWrapper result_ty
-- Base case 1: primitive types
| isUnLiftedType result_ty
= (Just result_ty, \e -> e)
-- Base case 1: the unit type ()
| result_ty == unitTy
= (Nothing, \e -> Var unitDataConId)
-- Booleans
| result_ty == boolTy
= returnDs (mkUnboxedTupleTy 2 [realWorldStatePrimTy, intPrimTy],
\ prim_app -> Case prim_app (mkWildId intPrimTy) [
(LitAlt (mkMachInt 0),[],Var falseDataConId),
(DEFAULT ,[],Var trueDataConId )])
= (Just intPrimTy, \e -> Case e (mkWildId intPrimTy)
[(LitAlt (mkMachInt 0),[],Var falseDataConId),
(DEFAULT ,[],Var trueDataConId )])
-- Data types with a single constructor, which has a single arg
| is_product_type && data_con_arity == 1
= let
(maybe_ty, wrapper) = resultWrapper unwrapped_res_ty
(unwrapped_res_ty : _) = data_con_arg_tys
in
(maybe_ty, \e -> mkApps (Var (dataConWrapId data_con))
(map Type tycon_arg_tys ++ [wrapper e]))
-- newtypes
| isNewType result_ty
= let
rep_ty = repType result_ty
(maybe_ty, wrapper) = resultWrapper rep_ty
in
(maybe_ty, \e -> mkCoerce result_ty rep_ty (wrapper e))
| otherwise
= pprPanic "boxResult: " (ppr result_ty)
= pprPanic "resultWrapper" (ppr result_ty)
where
maybe_product_type = splitProductType_maybe result_ty
is_product_type = maybeToBool maybe_product_type
Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) = maybe_product_type
(the_prim_result_ty : other_args_tys) = data_con_arg_tys
ccall_res_type = mkUnboxedTupleTy 2 [realWorldStatePrimTy, the_prim_result_ty]
-- wrap up an unboxed value.
wrapUnboxedValue :: Type -> DsM (Type, Id, CoreExpr)
wrapUnboxedValue ty
| (maybeToBool maybe_product_type) && -- Data type
not (null data_con_arg_tys) && null other_args_tys && -- Just one arg
isUnLiftedType the_prim_result_ty -- of primitive type
=
newSysLocalDs the_prim_result_ty `thenDs` \ prim_result_id ->
let
the_result = mkConApp data_con (map Type tycon_arg_tys ++ [Var prim_result_id])
in
returnDs (ccall_res_type, prim_result_id, the_result)
-- Data types with a single nullary constructor
| (maybeToBool maybe_product_type) && -- Data type
(null data_con_arg_tys)
=
let
scrut_ty = mkUnboxedTupleTy 1 [realWorldStatePrimTy]
in
returnDs (scrut_ty, unitDataConId, Var unitDataConId)
| otherwise
= pprPanic "boxResult: " (ppr ty)
where
maybe_product_type = splitProductType_maybe ty
Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) = maybe_product_type
(the_prim_result_ty : other_args_tys) = data_con_arg_tys
ccall_res_type = mkUnboxedTupleTy 2 [realWorldStatePrimTy, the_prim_result_ty]
data_con_arity = dataConSourceArity data_con
\end{code}
......@@ -15,9 +15,7 @@ import HsSyn ( failureFreePat,
mkSimpleMatch
)
import TcHsSyn ( TypecheckedHsExpr, TypecheckedHsBinds,
TypecheckedStmt,
maybeBoxedPrimType
TypecheckedStmt
)
import CoreSyn
import CoreUtils ( exprType, mkIfThenElse, bindNonRec )
......@@ -25,7 +23,7 @@ import CoreUtils ( exprType, mkIfThenElse, bindNonRec )
import DsMonad
import DsBinds ( dsMonoBinds, AutoScc(..) )
import DsGRHSs ( dsGuarded )
import DsCCall ( dsCCall )
import DsCCall ( dsCCall, resultWrapper )
import DsListComp ( dsListComp )
import DsUtils ( mkErrorAppDs, mkDsLets, mkConsExpr, mkNilExpr )
import Match ( matchWrapper, matchSimply )
......@@ -164,29 +162,11 @@ dsExpr (HsLitOut (HsString str) _)
= returnDs (mkStringLitFS str)
dsExpr (HsLitOut (HsLitLit str) ty)
| isUnLiftedType ty
= returnDs (mkLit (MachLitLit str ty))
| otherwise
= case (maybeBoxedPrimType ty) of
Just (boxing_data_con, prim_ty) ->
returnDs ( mkConApp boxing_data_con [mkLit (MachLitLit str prim_ty)] )
_ ->
pprError "ERROR:"
(vcat
[ hcat [ text "Cannot see data constructor of ``literal-literal''s type: "
, text "value:", quotes (quotes (ptext str))
, text "; type: ", ppr ty
]
, text "Try compiling with -fno-prune-tydecls."
])
= ASSERT( maybeToBool maybe_ty )
returnDs (wrap_fn (mkLit (MachLitLit str rep_ty)))
where
(data_con, prim_ty)
= case (maybeBoxedPrimType ty) of
Just (boxing_data_con, prim_ty) -> (boxing_data_con, prim_ty)
Nothing
-> pprPanic "ERROR: ``literal-literal'' not a single-constructor type: "
(hcat [ptext str, text "; type: ", ppr ty])
(maybe_ty, wrap_fn) = resultWrapper ty
Just rep_ty = maybe_ty
dsExpr (HsLitOut (HsInt i) ty)
= returnDs (mkIntegerLit i)
......
......@@ -12,7 +12,7 @@ module DsForeign ( dsForeigns ) where
import CoreSyn
import DsCCall ( dsCCall, mkCCall, boxResult, unboxArg, wrapUnboxedValue )
import DsCCall ( dsCCall, mkCCall, boxResult, unboxArg )
import DsMonad
import DsUtils
......@@ -23,15 +23,15 @@ import TcHsSyn ( TypecheckedForeignDecl )
import CoreUtils ( exprType, mkInlineMe, bindNonRec )
import DataCon ( DataCon, dataConWrapId )
import Id ( Id, idType, idName, mkWildId, mkVanillaId )
import MkId ( mkCCallOpId, mkWorkerId )
import MkId ( mkWorkerId )
import Literal ( Literal(..) )
import Module ( Module, moduleUserString )
import Name ( mkGlobalName, nameModule, nameOccName, getOccString,
mkForeignExportOcc, isLocalName,
NamedThing(..), Provenance(..), ExportFlag(..)
)
import PrelInfo ( deRefStablePtr_NAME, bindIO_NAME, makeStablePtr_NAME, realWorldPrimId )
import Type ( splitAlgTyConApp_maybe, unUsgTy,
import PrelInfo ( deRefStablePtr_NAME, bindIO_NAME, makeStablePtr_NAME )
import Type ( unUsgTy,
splitTyConApp_maybe, splitFunTys, splitForAllTys,
Type, mkFunTys, mkForAllTys, mkTyConApp,
mkTyVarTy, mkFunTy, splitAppTy
......@@ -45,10 +45,6 @@ import TysWiredIn ( unitTyCon, addrTy, stablePtrTyCon,
import Unique
import Maybes ( maybeToBool )
import Outputable
#if __GLASGOW_HASKELL__ >= 404
import GlaExts ( fromInt )
#endif
\end{code}
Desugaring of @foreign@ declarations is naturally split up into
......@@ -133,21 +129,12 @@ dsFImport :: Id
-> DsM [CoreBind]
dsFImport fn_id ty may_not_gc ext_name cconv
= let
(tvs, arg_tys, mbIoDataCon, io_res_ty) = splitForeignTyDs ty
is_io_action = maybeToBool mbIoDataCon
(tvs, fun_ty) = splitForAllTys ty
(arg_tys, io_res_ty) = splitFunTys fun_ty
in
newSysLocalsDs arg_tys `thenDs` \ args ->
newSysLocalDs realWorldStatePrimTy `thenDs` \ old_s ->
mapAndUnzipDs unboxArg (map Var args) `thenDs` \ (unboxed_args, arg_wrappers) ->
(if not is_io_action then
newSysLocalDs realWorldStatePrimTy `thenDs` \ state_tok ->
wrapUnboxedValue io_res_ty `thenDs` \ (ccall_result_ty, v, res_v) ->
returnDs ( ccall_result_ty
, \ prim_app -> Case prim_app (mkWildId ccall_result_ty)
[(DataAlt (unboxedTupleCon 2), [state_tok, v], res_v)])
else
boxResult io_res_ty) `thenDs` \ (ccall_result_ty, res_wrapper) ->
mapAndUnzipDs unboxArg (map Var args) `thenDs` \ (val_args, arg_wrappers) ->
boxResult io_res_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
(case ext_name of
Dynamic -> getUniqueDs `thenDs` \ u ->
......@@ -157,11 +144,7 @@ dsFImport fn_id ty may_not_gc ext_name cconv
getUniqueDs `thenDs` \ ccall_uniq ->
getUniqueDs `thenDs` \ work_uniq ->
let
the_state_arg | is_io_action = old_s
| otherwise = realWorldPrimId
-- Build the worker
val_args = Var the_state_arg : unboxed_args
work_arg_ids = [v | Var v <- val_args] -- All guaranteed to be vars
worker_ty = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
the_ccall = CCall lbl False (not may_not_gc) cconv
......@@ -172,32 +155,12 @@ dsFImport fn_id ty may_not_gc ext_name cconv
-- Build the wrapper
work_app = mkApps (mkVarApps (Var work_id) tvs) val_args
wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
io_app = case mbIoDataCon of
Nothing -> wrapper_body
Just ioDataCon -> mkApps (Var (dataConWrapId ioDataCon))
[Type io_res_ty, Lam old_s wrapper_body]
wrap_rhs = mkInlineMe (mkLams (tvs ++ args) io_app)
wrap_rhs = mkInlineMe (mkLams (tvs ++ args) wrapper_body)
in
returnDs [NonRec fn_id wrap_rhs, NonRec work_id work_rhs]
\end{code}
Given the type of a foreign import declaration, split it up into
its constituent parts.
\begin{code}
splitForeignTyDs :: Type -> ([TyVar], [Type], Maybe DataCon, Type)