import DsMonad
import HsSyn
-import TcHsSyn ( hsPatType )
+import TcHsSyn ( hsLPatType )
-- NB: The desugarer, which straddles the source and Core worlds, sometimes
-- needs to see source types (newtypes etc), and sometimes not
matchSimply (Var var) ProcExpr pat (mkTupleExpr env_ids) fail_expr
`thenDs` \ match_code ->
let
- pat_ty = hsPatType pat
+ pat_ty = hsLPatType pat
proc_code = do_map_arrow meth_ids pat_ty env_ty cmd_ty
(Lam var match_code)
core_cmd
dsLookupDataCon leftDataConName `thenDs` \ left_con ->
dsLookupDataCon rightDataConName `thenDs` \ right_con ->
let
- left_id = nlHsVar (dataConWrapId left_con)
- right_id = nlHsVar (dataConWrapId right_con)
- left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ TyApp left_id [ty1, ty2]) e
- right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ TyApp right_id [ty1, ty2]) e
+ left_id = HsVar (dataConWrapId left_con)
+ right_id = HsVar (dataConWrapId right_con)
+ left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsCoerce (CoTyApps [ty1, ty2]) left_id ) e
+ right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsCoerce (CoTyApps [ty1, ty2]) right_id) e
-- Prefix each tuple with a distinct series of Left's and Right's,
-- in a balanced way, keeping track of the types.
-- but that's likely to be defined in terms of first.
dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _ _)
- = dsfixCmd ids local_vars [] (hsPatType pat) cmd
+ = dsfixCmd ids local_vars [] (hsLPatType pat) cmd
`thenDs` \ (core_cmd, fv_cmd, env_ids1) ->
let
- pat_ty = hsPatType pat
+ pat_ty = hsLPatType pat
pat_vars = mkVarSet (collectPatBinders pat)
env_ids2 = varSetElems (mkVarSet out_ids `minusVarSet` pat_vars)
env_ty2 = mkTupleType env_ids2
= go expr
where
go (Var v) = lookupVarEnv subst v `orElse` Var v
+ go (Cast e co) = Cast (go e) co
go (Type ty) = Type ty
go (Lit lit) = Lit lit
go (App fun arg) = App (go fun) (go arg)
dsCoercion :: ExprCoFn -> DsM CoreExpr -> DsM CoreExpr
dsCoercion CoHole thing_inside = thing_inside
dsCoercion (CoCompose c1 c2) thing_inside = dsCoercion c1 (dsCoercion c2 thing_inside)
-dsCoercion (CoLams ids c) thing_inside = do { expr <- dsCoercion c thing_inside
+dsCoercion (ExprCoFn co) thing_inside = do { expr <- thing_inside
+ ; return (Cast expr co) }
+dsCoercion (CoLams ids) thing_inside = do { expr <- thing_inside
; return (mkLams ids expr) }
-dsCoercion (CoTyLams tvs c) thing_inside = do { expr <- dsCoercion c thing_inside
+dsCoercion (CoTyLams tvs) thing_inside = do { expr <- thing_inside
; return (mkLams tvs expr) }
-dsCoercion (CoApps c ids) thing_inside = do { expr <- dsCoercion c thing_inside
+dsCoercion (CoApps ids) thing_inside = do { expr <- thing_inside
; return (mkVarApps expr ids) }
-dsCoercion (CoTyApps c tys) thing_inside = do { expr <- dsCoercion c thing_inside
+dsCoercion (CoTyApps tys) thing_inside = do { expr <- thing_inside
; return (mkTyApps expr tys) }
-dsCoercion (CoLet bs c) thing_inside = do { prs <- dsLHsBinds bs
- ; expr <- dsCoercion c thing_inside
+dsCoercion (CoLet bs) thing_inside = do { prs <- dsLHsBinds bs
+ ; expr <- thing_inside
; return (Let (Rec prs) expr) }
\end{code}
import DsMonad
-import CoreUtils ( exprType, coreAltType, mkCoerce2 )
+import CoreUtils ( exprType, coreAltType, mkCoerce )
import Id ( Id, mkWildId )
import MkId ( mkFCallId, realWorldPrimId, mkPrimOpId )
import Maybes ( maybeToBool )
splitRecNewType_maybe, splitForAllTy_maybe,
isUnboxedTupleType
)
-
+import Coercion ( Coercion, splitRecNewTypeCo_maybe, mkSymCoercion )
import PrimOp ( PrimOp(..) )
import TysPrim ( realWorldStatePrimTy, intPrimTy,
byteArrayPrimTyCon, mutableByteArrayPrimTyCon,
-> [CoreExpr] -- Arguments (desugared)
-> Safety -- Safety of the call
-> Type -- Type of the result: IO t
- -> DsM CoreExpr
+ -> DsM CoreExpr -- Result, of type ???
dsCCall lbl args may_gc result_ty
= mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) ->
= returnDs (arg, \body -> body)
-- Recursive newtypes
- | Just rep_ty <- splitRecNewType_maybe arg_ty
- = unboxArg (mkCoerce2 rep_ty arg_ty arg)
+ | Just(rep_ty, co) <- splitRecNewTypeCo_maybe arg_ty
+ = unboxArg (mkCoerce (mkSymCoercion co) arg)
-- Booleans
| Just (tc,_) <- splitTyConApp_maybe arg_ty,
(LitAlt (mkMachInt 0),[],Var falseDataConId)])
-- Recursive newtypes
- | Just rep_ty <- splitRecNewType_maybe result_ty
+ | Just (rep_ty, co) <- splitRecNewTypeCo_maybe result_ty
= resultWrapper rep_ty `thenDs` \ (maybe_ty, wrapper) ->
- returnDs (maybe_ty, \e -> mkCoerce2 result_ty rep_ty (wrapper e))
+ returnDs (maybe_ty, \e -> mkCoerce co (wrapper e))
-- The type might contain foralls (eg. for dummy type arguments,
-- referring to 'Ptr a' is legal).
#endif
import HsSyn
-import TcHsSyn ( hsPatType, mkVanillaTuplePat )
+import TcHsSyn ( hsLPatType, mkVanillaTuplePat )
-- NB: The desugarer, which straddles the source and Core worlds, sometimes
-- needs to see source types (newtypes etc), and sometimes not
putSrcSpanDs loc $
do { rhs <- dsGuarded grhss ty
; let upat = unLoc pat
- eqn = EqnInfo { eqn_wrap = idWrapper, eqn_pats = [upat],
+ eqn = EqnInfo { eqn_pats = [upat],
eqn_rhs = cantFailMatchResult body_w_exports }
- ; var <- selectMatchVar upat ty
+ ; var <- selectMatchVar upat
; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
; return (scrungleMatch var rhs result) }
dsExpr (HsIPVar ip) = returnDs (Var (ipNameName ip))
dsExpr (HsLit lit) = dsLit lit
dsExpr (HsOverLit lit) = dsOverLit lit
+dsExpr (HsCoerce co_fn e) = dsCoercion co_fn (dsExpr e)
dsExpr (NegApp expr neg_expr)
= do { core_expr <- dsLExpr expr
extractIds (HsApp fn arg)
| HsVar argId <- unLoc arg
= argId:extractIds (unLoc fn)
- | TyApp arg' ts <- unLoc arg
- , HsVar argId <- unLoc arg'
- = error (showSDoc (ppr ts)) -- argId:extractIds (unLoc fn)
+ | HsCoerce co_fn arg' <- unLoc arg
+ , HsVar argId <- arg' -- SLPJ: not sure what is going on here
+ = error (showSDoc (ppr co_fn)) -- argId:extractIds (unLoc fn)
extractIds x = []
extractHVals ids = ExplicitList unitTy (map (L loc . HsVar) ids)
-- checks for tyvars and unlifted kinds.
\noindent
-\underline{\bf Type lambda and application}
-% ~~~~~~~~~~~~~~~~~~~~~~~~~~~
-\begin{code}
-dsExpr (TyLam tyvars expr)
- = dsLExpr expr `thenDs` \ core_expr ->
- returnDs (mkLams tyvars core_expr)
-
-dsExpr (TyApp expr tys)
- = dsLExpr expr `thenDs` \ core_expr ->
- returnDs (mkTyApps core_expr tys)
-\end{code}
-
-
-\noindent
\underline{\bf Various data construction things}
% ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
[] -> nlHsVar old_arg_id
mk_alt con
- = newSysLocalsDs (dataConInstOrigArgTys con in_inst_tys) `thenDs` \ arg_ids ->
+ = ASSERT( isVanillaDataCon con )
+ newSysLocalsDs (dataConInstOrigArgTys con in_inst_tys) `thenDs` \ arg_ids ->
-- This call to dataConInstOrigArgTys won't work for existentials
-- but existentials don't have record types anyway
let
val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
(dataConFieldLabels con) arg_ids
rhs = foldl (\a b -> nlHsApp a b)
- (noLoc $ TyApp (nlHsVar (dataConWrapId con))
- out_inst_tys)
- val_args
+ (nlHsTyApp (dataConWrapId con) out_inst_tys)
+ val_args
in
- returnDs (mkSimpleMatch [noLoc $ ConPatOut (noLoc con) [] [] emptyLHsBinds
- (PrefixCon (map nlVarPat arg_ids)) record_in_ty]
- rhs)
+ returnDs (mkSimpleMatch [mkPrefixConPat con (map nlVarPat arg_ids) record_in_ty] rhs)
in
-- Record stuff doesn't work for existentials
-- The type checker checks for this, but we need
con_fields = dataConFieldLabels con_id
\end{code}
-
-\noindent
-\underline{\bf Dictionary lambda and application}
-% ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-@DictLam@ and @DictApp@ turn into the regular old things.
-(OLD:) @DictFunApp@ also becomes a curried application, albeit slightly more
-complicated; reminiscent of fully-applied constructors.
-\begin{code}
-dsExpr (DictLam dictvars expr)
- = dsLExpr expr `thenDs` \ core_expr ->
- returnDs (mkLams dictvars core_expr)
-
-------------------
-
-dsExpr (DictApp expr dicts) -- becomes a curried application
- = dsLExpr expr `thenDs` \ core_expr ->
- returnDs (foldl (\f d -> f `App` (Var d)) core_expr dicts)
-
-dsExpr (HsCoerce co_fn e) = dsCoercion co_fn (dsExpr e)
-\end{code}
-
Here is where we desugar the Template Haskell brackets and escapes
\begin{code}
; match_code <- extractMatchResult match fail_expr
; rhs' <- dsLExpr rhs
- ; returnDs (mkApps (Var bind_id) [Type (hsPatType pat), Type b_ty,
+ ; returnDs (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty,
rhs', Lam var match_code]) }
go (RecStmt rec_stmts later_ids rec_ids rec_rets binds : stmts)
later_ids' = filter (`notElem` mono_rec_ids) later_ids
mono_rec_ids = [ id | HsVar id <- rec_rets ]
- mfix_app = nlHsApp (noLoc $ TyApp (nlHsVar mfix_id) [tup_ty]) mfix_arg
+ mfix_app = nlHsApp (nlHsTyApp mfix_id [tup_ty]) mfix_arg
mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
(mkFunTy tup_ty body_ty))
tup_ty = mkCoreTupTy (map idType (later_ids' ++ rec_ids))
-- mkCoreTupTy deals with singleton case
- return_app = nlHsApp (noLoc $ TyApp (nlHsVar return_id) [tup_ty])
+ return_app = nlHsApp (nlHsTyApp return_id [tup_ty])
(mk_ret_tup rets)
mk_wild_pat :: Id -> LPat Id
import Module ( moduleNameFS, moduleName )
import Name ( getOccString, NamedThing(..) )
import Type ( repType, coreEqType )
+import Coercion ( mkUnsafeCoercion )
import TcType ( Type, mkFunTys, mkForAllTys, mkTyConApp,
mkFunTy, tcSplitTyConApp_maybe, tcSplitIOType_maybe,
tcSplitForAllTys, tcSplitFunTys, tcTyConAppArgs,
f cback =
bindIO (newStablePtr cback)
(\StablePtr sp# -> IO (\s1# ->
- case _ccall_ createAdjustor cconv sp# ``f_helper'' s1# of
+ case _ccall_ createAdjustor cconv sp# ``f_helper'' <arg info> s1# of
(# s2#, a# #) -> (# s2#, A# a# #)))
foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun)
-- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
let ccall_adj_ty = exprType ccall_adj
ccall_io_adj = mkLams [stbl_value] $
- Note (Coerce io_res_ty ccall_adj_ty)
- ccall_adj
+ (pprTrace "DsForeign: why is there an unsafeCoerce here?" (text "") $
+ (Cast ccall_adj (mkUnsafeCoercion ccall_adj_ty io_res_ty )))
+
io_app = mkLams tvs $
mkLams [cback] $
stbl_app ccall_io_adj res_ty
import BasicTypes ( Boxity(..) )
import HsSyn
-import TcHsSyn ( hsPatType, mkVanillaTuplePat )
+import TcHsSyn ( hsLPatType, mkVanillaTuplePat )
import CoreSyn
import DsMonad -- the monadery used in the desugarer
u3_ty@u1_ty = exprType core_list1 -- two names, same thing
-- u1_ty is a [alpha] type, and u2_ty = alpha
- u2_ty = hsPatType pat
+ u2_ty = hsLPatType pat
res_ty = exprType core_list2
h_ty = u1_ty `mkFunTy` res_ty
= dsLExpr list1 `thenDs` \ core_list1 ->
-- find the required type
- let x_ty = hsPatType pat
+ let x_ty = hsLPatType pat
b_ty = idType n_id
in
deriving ()
data EquationInfo
- = EqnInfo { eqn_wrap :: DsWrapper, -- Bindings
- eqn_pats :: [Pat Id], -- The patterns for an eqn
+ = EqnInfo { eqn_pats :: [Pat Id], -- The patterns for an eqn
eqn_rhs :: MatchResult } -- What to do after match
type DsWrapper = CoreExpr -> CoreExpr
projects / ghc-hetmet.git / commitdiff