From: Manuel M T Chakravarty Date: Fri, 4 Aug 2006 19:56:07 +0000 (+0000) Subject: Massive patch for the first months work adding System FC to GHC #12 X-Git-Tag: After_FC_branch_merge~168 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=f1c0fd99f16322fe222c6fcf4626a6162ad0a466 Massive patch for the first months work adding System FC to GHC #12 Broken up massive patch -=chak Original log message: This is (sadly) all done in one patch to avoid Darcs bugs. It's not complete work... more FC stuff to come. A compiler using just this patch will fail dismally. --- diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs index 111e0bc..3484a5d 100644 --- a/compiler/deSugar/DsArrows.lhs +++ b/compiler/deSugar/DsArrows.lhs @@ -17,7 +17,7 @@ import DsUtils ( mkErrorAppDs, 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 @@ -262,7 +262,7 @@ dsProcExpr pat (L _ (HsCmdTop cmd [] cmd_ty ids)) 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 @@ -511,10 +511,10 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ 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. @@ -742,10 +742,10 @@ dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ c_ty) -- 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 diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index e22cb00..de8e981 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -323,6 +323,7 @@ simpleSubst subst expr = 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) @@ -421,16 +422,18 @@ addDictScc var rhs = returnDs rhs 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} diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs index 2ee9d08..0541f5d 100644 --- a/compiler/deSugar/DsCCall.lhs +++ b/compiler/deSugar/DsCCall.lhs @@ -19,7 +19,7 @@ import CoreSyn import DsMonad -import CoreUtils ( exprType, coreAltType, mkCoerce2 ) +import CoreUtils ( exprType, coreAltType, mkCoerce ) import Id ( Id, mkWildId ) import MkId ( mkFCallId, realWorldPrimId, mkPrimOpId ) import Maybes ( maybeToBool ) @@ -34,7 +34,7 @@ import Type ( Type, isUnLiftedType, mkFunTys, mkFunTy, splitRecNewType_maybe, splitForAllTy_maybe, isUnboxedTupleType ) - +import Coercion ( Coercion, splitRecNewTypeCo_maybe, mkSymCoercion ) import PrimOp ( PrimOp(..) ) import TysPrim ( realWorldStatePrimTy, intPrimTy, byteArrayPrimTyCon, mutableByteArrayPrimTyCon, @@ -109,7 +109,7 @@ dsCCall :: CLabelString -- C routine to invoke -> [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) -> @@ -160,8 +160,8 @@ unboxArg arg = 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, @@ -399,9 +399,9 @@ resultWrapper result_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). diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 8dfcd30..5ffae6d 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -34,7 +34,7 @@ import DsMeta ( dsBracket ) #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 @@ -130,9 +130,9 @@ ds_val_bind (NonRecursive, hsbinds) body 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) } @@ -205,6 +205,7 @@ dsExpr (HsVar var) = returnDs (Var var) 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 @@ -232,9 +233,9 @@ dsExpr (HsApp (L _ (HsApp realFun@(L _ (HsCoerce _ fun)) (L loc arg))) _) 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. @@ -352,20 +353,6 @@ dsExpr (HsIf guard_expr then_expr else_expr) \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} @@ -530,20 +517,18 @@ dsExpr expr@(RecordUpd record_expr rbinds record_in_ty record_out_ty) [] -> 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 @@ -578,27 +563,6 @@ dsExpr expr@(RecordUpd record_expr rbinds record_in_ty record_out_ty) 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} @@ -720,7 +684,7 @@ dsMDo tbl stmts body result_ty ; 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) @@ -738,7 +702,7 @@ dsMDo tbl stmts body result_ty 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)) @@ -755,7 +719,7 @@ dsMDo tbl stmts body result_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 diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index 5d47921..462da0e 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -31,6 +31,7 @@ import Literal ( Literal(..), mkStringLit ) 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, @@ -324,7 +325,7 @@ f :: Fun -> IO (FunPtr Fun) 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'' s1# of (# s2#, a# #) -> (# s2#, A# a# #))) foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun) @@ -402,8 +403,9 @@ dsFExportDynamic id cconv -- 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 diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs index 6bb41a9..2827fb6 100644 --- a/compiler/deSugar/DsListComp.lhs +++ b/compiler/deSugar/DsListComp.lhs @@ -12,7 +12,7 @@ import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds ) import BasicTypes ( Boxity(..) ) import HsSyn -import TcHsSyn ( hsPatType, mkVanillaTuplePat ) +import TcHsSyn ( hsLPatType, mkVanillaTuplePat ) import CoreSyn import DsMonad -- the monadery used in the desugarer @@ -197,7 +197,7 @@ deBindComp pat core_list1 quals body core_list2 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 @@ -313,7 +313,7 @@ dfListComp c_id n_id (BindStmt pat list1 _ _ : quals) body = 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 diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs index acdecfe..347f6b6 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/compiler/deSugar/DsMonad.lhs @@ -73,8 +73,7 @@ data DsMatchContext 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