import Foreign.StablePtr ( newStablePtr, castStablePtrToPtr )
import GHC.Exts ( Ptr(..), Int(..), addr2Int# )
import IOEnv ( ioToIOEnv )
-import PrelNames ( breakpointJumpName )
+import PrelNames ( breakpointJumpName, breakpointCondJumpName )
import TysWiredIn ( unitTy )
import TypeRep ( Type(..) )
+import TyCon ( isUnLiftedTyCon )
#endif
import Match ( matchWrapper, matchSinglePat, matchEquations )
import TcType ( tcSplitAppTy, tcSplitFunTys, tcTyConAppTyCon,
tcTyConAppArgs, isUnLiftedType, Type, mkAppTy )
-import Type ( funArgTy, splitFunTys, isUnboxedTupleType, mkFunTy )
+import Type ( splitFunTys, isUnboxedTupleType, mkFunTy )
import CoreSyn
import CoreUtils ( exprType, mkIfThenElse, bindNonRec )
import CostCentre ( mkUserCC )
import Id ( Id, idType, idName, idDataCon )
-import PrelInfo ( rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID )
+import PrelInfo ( rEC_CON_ERROR_ID )
import DataCon ( DataCon, dataConWrapId, dataConFieldLabels, dataConInstOrigArgTys )
import DataCon ( isVanillaDataCon )
import TyCon ( FieldLabel, tyConDataCons )
-------------------------
dsIPBinds (IPBinds ip_binds dict_binds) body
= do { prs <- dsLHsBinds dict_binds
- ; let inner = foldr (\(x,r) e -> Let (NonRec x r) e) body prs
+ ; let inner = Let (Rec prs) body
+ -- The dict bindings may not be in
+ -- dependency order; hence Rec
; foldrDs ds_ip_bind inner ip_binds }
where
ds_ip_bind (L _ (IPBind n e)) body
#if defined(GHCI) && defined(BREAKPOINT)
dsExpr (HsApp (L _ (HsApp realFun@(L _ (HsCoerce _ fun)) (L loc arg))) _)
| HsVar funId <- fun
- , idName funId == breakpointJumpName
- , ids <- filter (not.hasTyVar.idType) (extractIds arg)
- = do dsWarn (text "Extracted ids:" <+> ppr ids <+> ppr (map idType ids))
+ , idName funId `elem` [breakpointJumpName, breakpointCondJumpName]
+ , ids <- filter (isValidType . idType) (extractIds arg)
+ = do warnDs (text "Extracted ids:" <+> ppr ids <+> ppr (map idType ids))
stablePtr <- ioToIOEnv $ newStablePtr ids
-- Yes, I know... I'm gonna burn in hell.
let Ptr addr# = castStablePtrToPtr stablePtr
= error (showSDoc (ppr ts)) -- argId:extractIds (unLoc fn)
extractIds x = []
extractHVals ids = ExplicitList unitTy (map (L loc . HsVar) ids)
- hasTyVar (TyVarTy _) = True
- hasTyVar (FunTy a b) = hasTyVar a || hasTyVar b
- hasTyVar (NoteTy _ t) = hasTyVar t
- hasTyVar (AppTy a b) = hasTyVar a || hasTyVar b
- hasTyVar (TyConApp _ ts) = any hasTyVar ts
- hasTyVar _ = False
+ -- checks for tyvars and unlifted kinds.
+ isValidType (TyVarTy _) = False
+ isValidType (FunTy a b) = isValidType a && isValidType b
+ isValidType (NoteTy _ t) = isValidType t
+ isValidType (AppTy a b) = isValidType a && isValidType b
+ isValidType (TyConApp con ts) = not (isUnLiftedTyCon con) && all isValidType ts
+ isValidType _ = True
#endif
dsExpr expr@(HsApp fun arg)
dsLExpr e2 `thenDs` \ y_core ->
returnDs (mkApps core_op [x_core, y_core])
-dsExpr (SectionL expr op)
- = dsLExpr op `thenDs` \ core_op ->
- -- for the type of y, we need the type of op's 2nd argument
- let
- (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
- -- Must look through an implicit-parameter type;
- -- newtype impossible; hence Type.splitFunTys
- in
- dsLExpr expr `thenDs` \ x_core ->
- newSysLocalDs x_ty `thenDs` \ x_id ->
- newSysLocalDs y_ty `thenDs` \ y_id ->
-
- returnDs (bindNonRec x_id x_core $
- Lam y_id (mkApps core_op [Var x_id, Var y_id]))
+dsExpr (SectionL expr op) -- Desugar (e !) to ((!) e)
+ = dsLExpr op `thenDs` \ core_op ->
+ dsLExpr expr `thenDs` \ x_core ->
+ returnDs (App core_op x_core)
-- dsLExpr (SectionR op expr) -- \ x -> op x expr
dsExpr (SectionR op expr)