diff options
48 files changed, 398 insertions, 258 deletions
diff --git a/aclocal.m4 b/aclocal.m4 index 6d80ad3759..5652185b5e 100644 --- a/aclocal.m4 +++ b/aclocal.m4 @@ -363,12 +363,18 @@ AC_DEFUN([FP_SETTINGS], [ if test "$windows" = YES then - SettingsCCompilerCommand='$topdir/../mingw/bin/gcc.exe' + if test "$HostArch" = "x86_64" + then + mingw_bin_prefix=x86_64-w64-mingw32- + else + mingw_bin_prefix= + fi + SettingsCCompilerCommand="\$topdir/../mingw/bin/${mingw_bin_prefix}gcc.exe" SettingsCCompilerFlags="$CONF_CC_OPTS_STAGE2 $CONF_GCC_LINKER_OPTS_STAGE2" - SettingsArCommand='$topdir/../mingw/bin/ar.exe' + SettingsArCommand="\$topdir/../mingw/bin/${mingw_bin_prefix}ar.exe" SettingsPerlCommand='$topdir/../perl/perl.exe' - SettingsDllWrapCommand='$topdir/../mingw/bin/dllwrap.exe' - SettingsWindresCommand='$topdir/../mingw/bin/windres.exe' + SettingsDllWrapCommand="\$topdir/../mingw/bin/${mingw_bin_prefix}dllwrap.exe" + SettingsWindresCommand="\$topdir/../mingw/bin/${mingw_bin_prefix}windres.exe" SettingsTouchCommand='$topdir/touchy.exe' else SettingsCCompilerCommand="$WhatGccIsCalled" @@ -686,7 +692,8 @@ case $HostPlatform in esac ;; alpha-dec-osf*) fptools_cv_leading_underscore=no;; *cygwin32) fptools_cv_leading_underscore=yes;; -*mingw32) fptools_cv_leading_underscore=yes;; +i386-unknown-mingw32) fptools_cv_leading_underscore=yes;; +x86_64-unknown-mingw32) fptools_cv_leading_underscore=no;; # HACK: Apple doesn't seem to provide nlist in the 64-bit-libraries x86_64-apple-darwin*) fptools_cv_leading_underscore=yes;; @@ -776,9 +783,9 @@ dnl AC_DEFUN([FPTOOLS_HAPPY], [AC_PATH_PROG(HappyCmd,happy,) # Happy is passed to Cabal, so we need a native path -if test "x$HostPlatform" = "xi386-unknown-mingw32" && \ - test "${OSTYPE}" != "msys" && \ - test "${HappyCmd}" != "" +if test "$HostOS" = "mingw32" && \ + test "${OSTYPE}" != "msys" && \ + test "${HappyCmd}" != "" then # Canonicalise to <drive>:/path/to/gcc HappyCmd=`cygpath -m "${HappyCmd}"` @@ -812,9 +819,9 @@ AC_DEFUN([FPTOOLS_ALEX], [ AC_PATH_PROG(AlexCmd,alex,) # Alex is passed to Cabal, so we need a native path -if test "x$HostPlatform" = "xi386-unknown-mingw32" && \ - test "${OSTYPE}" != "msys" && \ - test "${AlexCmd}" != "" +if test "$HostOS" = "mingw32" && \ + test "${OSTYPE}" != "msys" && \ + test "${AlexCmd}" != "" then # Canonicalise to <drive>:/path/to/gcc AlexCmd=`cygpath -m "${AlexCmd}"` diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index 9da00590c2..346b108fa4 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -1107,10 +1107,11 @@ pprHexVal w rep -- times values are unsigned. This also helps eliminate occasional -- warnings about integer overflow from gcc. - -- on 32-bit platforms, add "ULL" to 64-bit literals - repsuffix W64 | wORD_SIZE == 4 = ptext (sLit "ULL") - -- on 64-bit platforms with 32-bit int, add "L" to 64-bit literals - repsuffix W64 | cINT_SIZE == 4 = ptext (sLit "UL") + repsuffix W64 + | cINT_SIZE == 8 = char 'U' + | cLONG_SIZE == 8 = ptext (sLit "UL") + | cLONG_LONG_SIZE == 8 = ptext (sLit "ULL") + | otherwise = panic "pprHexVal: Can't find a 64-bit type" repsuffix _ = char 'U' go 0 = empty diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index ed288096f7..7f107137b6 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -870,10 +870,12 @@ get to a partial application: \begin{code} tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr tryEtaReducePrep bndrs expr@(App _ _) - | ok_to_eta_reduce f && - n_remaining >= 0 && - and (zipWith ok bndrs last_args) && - not (any (`elemVarSet` fvs_remaining) bndrs) + | ok_to_eta_reduce f + , n_remaining >= 0 + , and (zipWith ok bndrs last_args) + , not (any (`elemVarSet` fvs_remaining) bndrs) + , exprIsHNF remaining_expr -- Don't turn value into a non-value + -- else the behaviour with 'seq' changes = Just remaining_expr where (f, args) = collectArgs expr @@ -885,9 +887,9 @@ tryEtaReducePrep bndrs expr@(App _ _) ok bndr (Var arg) = bndr == arg ok _ _ = False - -- we can't eta reduce something which must be saturated. + -- We can't eta reduce something which must be saturated. ok_to_eta_reduce (Var f) = not (hasNoBinding f) - ok_to_eta_reduce _ = False --safe. ToDo: generalise + ok_to_eta_reduce _ = False -- Safe. ToDo: generalise tryEtaReducePrep bndrs (Let bind@(NonRec _ r) body) | not (any (`elemVarSet` fvs) bndrs) diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index bef7b5da8d..2b72a923dd 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -124,16 +124,16 @@ repTopDs group -- return (Data t [] ...more t's... } -- The other important reason is that the output must mention -- only "T", not "Foo:T" where Foo is the current module - decls <- addBinds ss (do { + fix_ds <- mapM repFixD (hs_fixds group) ; val_ds <- rep_val_binds (hs_valds group) ; tycl_ds <- mapM repTyClD (concat (hs_tyclds group)) ; inst_ds <- mapM repInstD (hs_instds group) ; for_ds <- mapM repForD (hs_fords group) ; -- more needed return (de_loc $ sort_by_loc $ - val_ds ++ catMaybes tycl_ds + val_ds ++ catMaybes tycl_ds ++ fix_ds ++ catMaybes inst_ds ++ for_ds) }) ; decl_ty <- lookupType decQTyConName ; @@ -175,15 +175,16 @@ repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ)) repTyClD tydecl@(L _ (TyFamily {})) = repTyFamily tydecl addTyVarBinds -repTyClD (L loc (TyData { tcdND = DataType, tcdCtxt = cxt, +repTyClD (L loc (TyData { tcdND = DataType, tcdCtxt = cxt, tcdKindSig = mb_kind, tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys, tcdCons = cons, tcdDerivs = mb_derivs })) = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] - ; dec <- addTyVarBinds tvs $ \bndrs -> + ; tc_tvs <- mk_extra_tvs tvs mb_kind + ; dec <- addTyVarBinds tc_tvs $ \bndrs -> do { cxt1 <- repLContext cxt ; opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1 - ; cons1 <- mapM (repC (hsLTyVarNames tvs)) cons + ; cons1 <- mapM (repC (hsLTyVarNames tc_tvs)) cons ; cons2 <- coreList conQTyConName cons1 ; derivs1 <- repDerivs mb_derivs ; bndrs1 <- coreList tyVarBndrTyConName bndrs @@ -192,15 +193,16 @@ repTyClD (L loc (TyData { tcdND = DataType, tcdCtxt = cxt, ; return $ Just (loc, dec) } -repTyClD (L loc (TyData { tcdND = NewType, tcdCtxt = cxt, +repTyClD (L loc (TyData { tcdND = NewType, tcdCtxt = cxt, tcdKindSig = mb_kind, tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys, tcdCons = [con], tcdDerivs = mb_derivs })) = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] - ; dec <- addTyVarBinds tvs $ \bndrs -> + ; tc_tvs <- mk_extra_tvs tvs mb_kind + ; dec <- addTyVarBinds tc_tvs $ \bndrs -> do { cxt1 <- repLContext cxt ; opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1 - ; con1 <- repC (hsLTyVarNames tvs) con + ; con1 <- repC (hsLTyVarNames tc_tvs) con ; derivs1 <- repDerivs mb_derivs ; bndrs1 <- coreList tyVarBndrTyConName bndrs ; repNewtype cxt1 tc1 bndrs1 opt_tys2 con1 derivs1 @@ -244,6 +246,35 @@ repTyClD (L loc d) = putSrcSpanDs loc $ do { warnDs (hang ds_msg 4 (ppr d)) ; return Nothing } +------------------------- +mk_extra_tvs :: [LHsTyVarBndr Name] -> Maybe (HsBndrSig (LHsKind Name)) -> DsM [LHsTyVarBndr Name] +-- If there is a kind signature it must be of form +-- k1 -> .. -> kn -> * +-- Return type variables [tv1:k1, tv2:k2, .., tvn:kn] +mk_extra_tvs tvs Nothing + = return tvs +mk_extra_tvs tvs (Just (HsBSig hs_kind _)) + = do { extra_tvs <- go hs_kind + ; return (tvs ++ extra_tvs) } + where + go :: LHsKind Name -> DsM [LHsTyVarBndr Name] + go (L loc (HsFunTy kind rest)) + = do { uniq <- newUnique + ; let { occ = mkTyVarOccFS (fsLit "t") + ; nm = mkInternalName uniq occ loc + ; hs_tv = L loc (KindedTyVar nm (HsBSig kind placeHolderBndrs)) } + ; hs_tvs <- go rest + ; return (hs_tv : hs_tvs) } + + go (L _ (HsTyVar n)) + | n == liftedTypeKindTyConName + = return [] + + go _ = failWithDs (hang (ptext (sLit "Malformed kind signature")) + 2 (ppr hs_kind)) + + +------------------------- -- The type variables in the head of families are treated differently when the -- family declaration is associated. In that case, they are usage, not binding -- occurences. @@ -261,9 +292,9 @@ repTyFamily (L loc (TyFamily { tcdFlavour = flavour, ; bndrs1 <- coreList tyVarBndrTyConName bndrs ; case opt_kind of Nothing -> repFamilyNoKind flav tc1 bndrs1 - Just ki -> do { ki1 <- repKind ki - ; repFamilyKind flav tc1 bndrs1 ki1 - } + Just (HsBSig ki _) + -> do { ki1 <- repKind ki + ; repFamilyKind flav tc1 bndrs1 ki1 } } ; return $ Just (loc, dec) } @@ -314,7 +345,7 @@ repInstD (L loc (FamInstDecl fi_decl)) = repTyClD (L loc fi_decl) -repInstD (L loc (ClsInstDecl ty binds _ ats)) -- Ignore user pragmas for now +repInstD (L loc (ClsInstDecl ty binds prags ats)) = do { dec <- addTyVarBinds tvs $ \_ -> -- We must bring the type variables into scope, so their -- occurrences don't fail, even though the binders don't @@ -330,8 +361,9 @@ repInstD (L loc (ClsInstDecl ty binds _ ats)) -- Ignore user pragmas for now ; cls_tys <- repLTys tys ; inst_ty1 <- repTapps cls_tcon cls_tys ; binds1 <- rep_binds binds + ; prags1 <- rep_sigs prags ; ats1 <- repLAssocFamInst ats - ; decls <- coreList decQTyConName (ats1 ++ binds1) + ; decls <- coreList decQTyConName (ats1 ++ binds1 ++ prags1) ; repInst cxt1 inst_ty1 decls } ; return (Just (loc, dec)) } where @@ -371,6 +403,17 @@ repSafety PlayRisky = rep2 unsafeName [] repSafety PlayInterruptible = rep2 interruptibleName [] repSafety PlaySafe = rep2 safeName [] +repFixD :: LFixitySig Name -> DsM (SrcSpan, Core TH.DecQ) +repFixD (L loc (FixitySig name (Fixity prec dir))) + = do { MkC name' <- lookupLOcc name + ; MkC prec' <- coreIntLit prec + ; let rep_fn = case dir of + InfixL -> infixLDName + InfixR -> infixRDName + InfixN -> infixNDName + ; dec <- rep2 rep_fn [prec', name'] + ; return (loc, dec) } + ds_msg :: SDoc ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:") @@ -426,7 +469,7 @@ mkGadtCtxt data_tvs (ResTyGADT res_ty) = return (go [] [] (data_tvs `zip` tys)) | otherwise - = failWithDs (ptext (sLit "Malformed constructor result type") <+> ppr res_ty) + = failWithDs (ptext (sLit "Malformed constructor result type:") <+> ppr res_ty) where go cxt subst [] = (cxt, subst) go cxt subst ((data_tv, ty) : rest) @@ -607,7 +650,7 @@ repTyVarBndrWithKind :: LHsTyVarBndr Name -> Core TH.Name -> DsM (Core TH.TyVarBndr) repTyVarBndrWithKind (L _ (UserTyVar {})) nm = repPlainTV nm -repTyVarBndrWithKind (L _ (KindedTyVar _ (HsBSig ki _) _)) nm +repTyVarBndrWithKind (L _ (KindedTyVar _ (HsBSig ki _))) nm = repKind ki >>= repKindedTV nm -- represent a type context @@ -1767,7 +1810,7 @@ templateHaskellNames = [ classDName, instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName, pragSpecInlDName, familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName, - tySynInstDName, + tySynInstDName, infixLDName, infixRDName, infixNDName, -- Cxt cxtName, -- Pred @@ -1963,7 +2006,8 @@ parSName = libFun (fsLit "parS") parSIdKey funDName, valDName, dataDName, newtypeDName, tySynDName, classDName, instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName, pragSpecInlDName, familyNoKindDName, familyKindDName, dataInstDName, - newtypeInstDName, tySynInstDName :: Name + newtypeInstDName, tySynInstDName, + infixLDName, infixRDName, infixNDName :: Name funDName = libFun (fsLit "funD") funDIdKey valDName = libFun (fsLit "valD") valDIdKey dataDName = libFun (fsLit "dataD") dataDIdKey @@ -1981,6 +2025,9 @@ familyKindDName = libFun (fsLit "familyKindD") familyKindDIdKey dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey +infixLDName = libFun (fsLit "infixLD") infixLDIdKey +infixRDName = libFun (fsLit "infixRD") infixRDIdKey +infixNDName = libFun (fsLit "infixND") infixNDIdKey -- type Ctxt = ... cxtName :: Name @@ -2245,7 +2292,8 @@ parSIdKey = mkPreludeMiscIdUnique 323 funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey, pragSpecDIdKey, pragSpecInlDIdKey, familyNoKindDIdKey, familyKindDIdKey, - dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey :: Unique + dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey, + infixLDIdKey, infixRDIdKey, infixNDIdKey :: Unique funDIdKey = mkPreludeMiscIdUnique 330 valDIdKey = mkPreludeMiscIdUnique 331 dataDIdKey = mkPreludeMiscIdUnique 332 @@ -2263,6 +2311,9 @@ familyKindDIdKey = mkPreludeMiscIdUnique 343 dataInstDIdKey = mkPreludeMiscIdUnique 344 newtypeInstDIdKey = mkPreludeMiscIdUnique 345 tySynInstDIdKey = mkPreludeMiscIdUnique 346 +infixLDIdKey = mkPreludeMiscIdUnique 347 +infixRDIdKey = mkPreludeMiscIdUnique 348 +infixNDIdKey = mkPreludeMiscIdUnique 349 -- type Cxt = ... cxtIdKey :: Unique diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 014094c1d5..b4b3c0e924 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -405,8 +405,9 @@ endif endif ifeq "$(compiler_stage1_VERSION_MUNGED)" "YES" +compiler_stage1_MUNGED_VERSION = $(subst .$(ProjectPatchLevel),,$(ProjectVersion)) define compiler_PACKAGE_MAGIC -compiler_stage1_VERSION = $(subst .$(ProjectPatchLevel),,$(ProjectVersion)) +compiler_stage1_VERSION = $(compiler_stage1_MUNGED_VERSION) endef # Don't register the non-munged package diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 0072abc13e..b0cd2f4340 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -154,6 +154,10 @@ cvtDec (TH.SigD nm typ) ; ty' <- cvtType typ ; returnL $ Hs.SigD (TypeSig [nm'] ty') } +cvtDec (TH.InfixD fx nm) + = do { nm' <- vNameL nm + ; returnL (Hs.SigD (FixSig (FixitySig nm' (cvtFixity fx)))) } + cvtDec (PragmaD prag) = do { prag' <- cvtPragmaD prag ; returnL $ Hs.SigD prag' } @@ -250,7 +254,7 @@ cvt_ci_decs :: MsgDoc -> [TH.Dec] -- ie signatures, bindings, and associated types cvt_ci_decs doc decs = do { decs' <- mapM cvtDec decs - ; let (ats', bind_sig_decs') = partitionWith is_tycl decs' + ; let (ats', bind_sig_decs') = partitionWith is_fam_inst decs' ; let (sigs', prob_binds') = partitionWith is_sig bind_sig_decs' ; let (binds', bads) = partitionWith is_bind prob_binds' ; unless (null bads) (failWith (mkBadDecMsg doc bads)) @@ -303,9 +307,9 @@ cvt_tyinst_hdr cxt tc tys -- Partitioning declarations ------------------------------------------------------------------- -is_tycl :: LHsDecl RdrName -> Either (LTyClDecl RdrName) (LHsDecl RdrName) -is_tycl (L loc (Hs.TyClD tcd)) = Left (L loc tcd) -is_tycl decl = Right decl +is_fam_inst :: LHsDecl RdrName -> Either (LTyClDecl RdrName) (LHsDecl RdrName) +is_fam_inst (L loc (Hs.InstD (FamInstDecl d))) = Left (L loc d) +is_fam_inst decl = Right decl is_sig :: LHsDecl RdrName -> Either (LSig RdrName) (LHsDecl RdrName) is_sig (L loc (Hs.SigD sig)) = Left (L loc sig) @@ -792,12 +796,11 @@ cvtTvs tvs = mapM cvt_tv tvs cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName) cvt_tv (TH.PlainTV nm) = do { nm' <- tName nm - ; returnL $ UserTyVar nm' placeHolderKind - } + ; returnL $ UserTyVar nm' } cvt_tv (TH.KindedTV nm ki) = do { nm' <- tName nm ; ki' <- cvtKind ki - ; returnL $ KindedTyVar nm' (HsBSig ki' placeHolderBndrs) placeHolderKind } + ; returnL $ KindedTyVar nm' (HsBSig ki' placeHolderBndrs) } cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName) cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' } @@ -878,9 +881,18 @@ cvtKind (ArrowK k1 k2) = do k2' <- cvtKind k2 returnL (HsFunTy k1' k2') -cvtMaybeKind :: Maybe TH.Kind -> CvtM (Maybe (LHsKind RdrName)) +cvtMaybeKind :: Maybe TH.Kind -> CvtM (Maybe (HsBndrSig (LHsKind RdrName))) cvtMaybeKind Nothing = return Nothing -cvtMaybeKind (Just ki) = cvtKind ki >>= return . Just +cvtMaybeKind (Just ki) = do { ki' <- cvtKind ki + ; return (Just (HsBSig ki' placeHolderBndrs)) } + +----------------------------------------------------------- +cvtFixity :: TH.Fixity -> Hs.Fixity +cvtFixity (TH.Fixity prec dir) = Hs.Fixity prec (cvt_dir dir) + where + cvt_dir TH.InfixL = Hs.InfixL + cvt_dir TH.InfixR = Hs.InfixR + cvt_dir TH.InfixN = Hs.InfixN ----------------------------------------------------------- diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 26d49f726c..d3231696fa 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -452,7 +452,7 @@ data TyClDecl name TyFamily { tcdFlavour :: FamilyFlavour, -- type or data tcdLName :: Located name, -- type constructor tcdTyVars :: [LHsTyVarBndr name], -- type variables - tcdKindSig :: Maybe (LHsKind name) -- result kind + tcdKindSig :: Maybe (HsBndrSig (LHsKind name)) -- result kind } @@ -470,7 +470,7 @@ data TyClDecl name tcdTyPats :: Maybe [LHsType name], -- ^ Type patterns. -- See Note [tcdTyVars and tcdTyPats] - tcdKindSig:: Maybe (LHsKind name), + tcdKindSig:: Maybe (HsBndrSig (LHsKind name)), -- ^ Optional kind signature. -- -- @(Just k)@ for a GADT-style @data@, or @data @@ -667,7 +667,7 @@ instance OutputableBndr name derivings where ppr_sigx Nothing = empty - ppr_sigx (Just kind) = dcolon <+> ppr kind + ppr_sigx (Just (HsBSig kind _)) = dcolon <+> ppr kind ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, tcdFDs = fds, diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index 39181f7eb1..9e8d27bde0 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -31,7 +31,6 @@ module HsTypes ( mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs, hsTyVarName, hsTyVarNames, - hsTyVarKind, hsLTyVarKind, hsTyVarNameKind, hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames, splitHsInstDeclTy_maybe, splitLHsInstDeclTy_maybe, splitHsForAllTy, splitLHsForAllTy, @@ -144,12 +143,10 @@ placeHolderBndrs = panic "placeHolderBndrs" data HsTyVarBndr name = UserTyVar -- No explicit kinding name -- See Note [Printing KindedTyVars] - PostTcKind | KindedTyVar name (HsBndrSig (LHsKind name)) -- The user-supplied kind signature - PostTcKind -- *** NOTA BENE *** A "monotype" in a pragma can have -- for-alls in it, (mostly to do with dictionaries). These -- must be explicitly Kinded. @@ -383,19 +380,8 @@ hsExplicitTvs _ = [] --------------------- hsTyVarName :: HsTyVarBndr name -> name -hsTyVarName (UserTyVar n _) = n -hsTyVarName (KindedTyVar n _ _) = n - -hsTyVarKind :: HsTyVarBndr name -> Kind -hsTyVarKind (UserTyVar _ k) = k -hsTyVarKind (KindedTyVar _ _ k) = k - -hsLTyVarKind :: LHsTyVarBndr name -> Kind -hsLTyVarKind = hsTyVarKind . unLoc - -hsTyVarNameKind :: HsTyVarBndr name -> (name, Kind) -hsTyVarNameKind (UserTyVar n k) = (n,k) -hsTyVarNameKind (KindedTyVar n _ k) = (n,k) +hsTyVarName (UserTyVar n) = n +hsTyVarName (KindedTyVar n _) = n hsLTyVarName :: LHsTyVarBndr name -> name hsLTyVarName = hsTyVarName . unLoc @@ -505,8 +491,8 @@ instance (Outputable sig) => Outputable (HsBndrSig sig) where ppr (HsBSig ty _) = ppr ty instance (OutputableBndr name) => Outputable (HsTyVarBndr name) where - ppr (UserTyVar name _) = ppr name - ppr (KindedTyVar name kind _) = parens $ hsep [ppr name, dcolon, ppr kind] + ppr (UserTyVar name) = ppr name + ppr (KindedTyVar name kind) = parens $ hsep [ppr name, dcolon, ppr kind] pprHsForAll :: OutputableBndr name => HsExplicitFlag -> [LHsTyVarBndr name] -> LHsContext name -> SDoc pprHsForAll exp tvs cxt diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index f7a1a10a5b..729532da2a 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -268,7 +268,7 @@ mkHsString s = HsString (mkFastString s) ------------- userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)] -userHsTyVarBndrs bndrs = [ L loc (UserTyVar v placeHolderKind) | L loc v <- bndrs ] +userHsTyVarBndrs bndrs = [ L loc (UserTyVar v) | L loc v <- bndrs ] \end{code} diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 0dd90f5337..38cada8185 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -726,9 +726,9 @@ data_or_newtype :: { Located NewOrData } : 'data' { L1 DataType } | 'newtype' { L1 NewType } -opt_kind_sig :: { Located (Maybe (LHsKind RdrName)) } +opt_kind_sig :: { Located (Maybe (HsBndrSig (LHsKind RdrName))) } : { noLoc Nothing } - | '::' kind { LL (Just $2) } + | '::' kind { LL (Just (HsBSig $2 placeHolderBndrs)) } -- tycl_hdr parses the header of a class or data type decl, -- which takes the form @@ -1107,8 +1107,8 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] } | {- empty -} { [] } tv_bndr :: { LHsTyVarBndr RdrName } - : tyvar { L1 (UserTyVar (unLoc $1) placeHolderKind) } - | '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2) (HsBSig $4 placeHolderBndrs) placeHolderKind) } + : tyvar { L1 (UserTyVar (unLoc $1)) } + | '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2) (HsBSig $4 placeHolderBndrs)) } fds :: { Located [Located (FunDep RdrName)] } : {- empty -} { noLoc [] } diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y index 872bcdefc0..4311c2522d 100644 --- a/compiler/parser/ParserCore.y +++ b/compiler/parser/ParserCore.y @@ -375,7 +375,7 @@ ifaceUnliftedTypeKind = ifaceTcType (IfaceTc unliftedTypeKindTyConName) ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2 toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName -toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) bsig placeHolderKind +toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) bsig where bsig = HsBSig (toHsKind k) placeHolderBndrs diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 1bb7695b7d..a847f55d19 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -203,7 +203,7 @@ mkTyData :: SrcSpan -> Bool -- True <=> data family instance -> Maybe CType -> Located (Maybe (LHsContext RdrName), LHsType RdrName) - -> Maybe (LHsKind RdrName) + -> Maybe (HsBndrSig (LHsKind RdrName)) -> [LConDecl RdrName] -> Maybe [LHsType RdrName] -> P (LTyClDecl RdrName) @@ -217,7 +217,8 @@ mkTyData loc new_or_data is_family cType (L _ (mcxt, tycl_hdr)) ksig data_cons m tcdCtxt = cxt, tcdLName = tc, tcdTyVars = tyvars, tcdTyPats = typats, tcdCons = data_cons, - tcdKindSig = ksig, tcdDerivs = maybe_deriv })) } + tcdKindSig = ksig, + tcdDerivs = maybe_deriv })) } mkTySynonym :: SrcSpan -> Bool -- True <=> type family instances @@ -234,7 +235,7 @@ mkTySynonym loc is_family lhs rhs mkTyFamily :: SrcSpan -> FamilyFlavour -> LHsType RdrName -- LHS - -> Maybe (LHsKind RdrName) -- Optional kind signature + -> Maybe (HsBndrSig (LHsKind RdrName)) -- Optional kind signature -> P (LTyClDecl RdrName) mkTyFamily loc flavour lhs ksig = do { (tc, tparams) <- checkTyClHdr lhs @@ -523,9 +524,9 @@ checkTyVars tycl_hdr tparms = mapM chk tparms where -- Check that the name space is correct! chk (L l (HsKindSig (L _ (HsTyVar tv)) k)) - | isRdrTyVar tv = return (L l (KindedTyVar tv (HsBSig k placeHolderBndrs) placeHolderKind)) + | isRdrTyVar tv = return (L l (KindedTyVar tv (HsBSig k placeHolderBndrs))) chk (L l (HsTyVar tv)) - | isRdrTyVar tv = return (L l (UserTyVar tv placeHolderKind)) + | isRdrTyVar tv = return (L l (UserTyVar tv)) chk t@(L l _) = parseErrorSDoc l $ vcat [ sep [ ptext (sLit "Unexpected type") <+> quotes (ppr t) diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index 734eee3dad..cff6e322f6 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -106,12 +106,13 @@ rnLHsType = rnLHsTyKi True rnLHsKind :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name, FreeVars) rnLHsKind = rnLHsTyKi False -rnLHsMaybeKind :: HsDocContext -> Maybe (LHsKind RdrName) - -> RnM (Maybe (LHsKind Name), FreeVars) -rnLHsMaybeKind _ Nothing = return (Nothing, emptyFVs) -rnLHsMaybeKind doc (Just k) - = do { (k', fvs) <- rnLHsKind doc k - ; return (Just k', fvs) } +rnLHsMaybeKind :: HsDocContext -> Maybe (HsBndrSig (LHsKind RdrName)) + -> RnM (Maybe (HsBndrSig (LHsKind Name)), FreeVars) +rnLHsMaybeKind _ Nothing + = return (Nothing, emptyFVs) +rnLHsMaybeKind doc (Just bsig) + = rnHsBndrSig False doc bsig $ \ bsig' -> + return (Just bsig', emptyFVs) rnHsType :: HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars) rnHsType = rnHsTyKi True @@ -412,14 +413,14 @@ bindTyVarsRn doc tv_bndrs names thing_inside where go [] [] thing_inside = thing_inside [] - go (L loc (UserTyVar _ tck) : tvs) (n : ns) thing_inside + go (L loc (UserTyVar _) : tvs) (n : ns) thing_inside = go tvs ns $ \ tvs' -> - thing_inside (L loc (UserTyVar n tck) : tvs') + thing_inside (L loc (UserTyVar n) : tvs') - go (L loc (KindedTyVar _ bsig tck) : tvs) (n : ns) thing_inside + go (L loc (KindedTyVar _ bsig) : tvs) (n : ns) thing_inside = rnHsBndrSig False doc bsig $ \ bsig' -> go tvs ns $ \ tvs' -> - thing_inside (L loc (KindedTyVar n bsig' tck) : tvs') + thing_inside (L loc (KindedTyVar n bsig') : tvs') -- Lists of unequal length go tvs names _ = pprPanic "bindTyVarsRn" (ppr tvs $$ ppr names) @@ -896,7 +897,8 @@ checkTH _ _ = return () -- OK #else checkTH e what -- Raise an error in a stage-1 compiler = addErr (vcat [ptext (sLit "Template Haskell") <+> text what <+> - ptext (sLit "illegal in a stage-1 compiler"), + ptext (sLit "requires GHC with interpreter support"), + ptext (sLit "Perhaps you are using a stage-1 compiler?"), nest 2 (ppr e)]) #endif \end{code} diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index d97a0884f9..604db4de47 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -20,7 +20,7 @@ module TcEnv( tcLookupLocatedClass, tcLookupInstance, tcLookupAxiom, -- Local environment - tcExtendKindEnv, tcExtendKindEnvTvs, tcExtendTcTyThingEnv, + tcExtendKindEnv, tcExtendTcTyThingEnv, tcExtendTyVarEnv, tcExtendTyVarEnv2, tcExtendGhciEnv, tcExtendLetEnv, tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, @@ -340,11 +340,6 @@ tcExtendKindEnv things thing_inside upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) } extend env = extendNameEnvList env [(n, AThing k) | (n,k) <- things] -tcExtendKindEnvTvs :: [LHsTyVarBndr Name] -> ([LHsTyVarBndr Name] -> TcM r) -> TcM r -tcExtendKindEnvTvs bndrs thing_inside - = tcExtendKindEnv (map (hsTyVarNameKind . unLoc) bndrs) - (thing_inside bndrs) - ----------------------- -- Scoped type and kind variables tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index 7379ca2ae9..7bda323f5b 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -48,8 +48,6 @@ import Platform import SrcLoc import Bag import FastString - -import Control.Monad \end{code} \begin{code} @@ -210,14 +208,14 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ (CLabel _)) ; return idecl } -- NB check res_ty not sig_ty! -- In case sig_ty is (forall a. ForeignPtr a) -tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ CWrapper) = do +tcCheckFIType sig_ty arg_tys res_ty (CImport cconv safety mh CWrapper) = do -- Foreign wrapper (former f.e.d.) -- The type must be of the form ft -> IO (FunPtr ft), where ft is a -- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well -- as ft -> IO Addr is accepted, too. The use of the latter two forms -- is DEPRECATED, though. checkCg checkCOrAsmOrLlvmOrInterp - checkCConv cconv + cconv' <- checkCConv cconv case arg_tys of [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys checkForeignRes nonIOok checkSafe isFFIExportResultTy res1_ty @@ -226,23 +224,22 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ CWrapper) = do where (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty _ -> addErrTc (illegalForeignTyErr empty sig_ty) - return idecl + return (CImport cconv' safety mh CWrapper) -tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction target)) +tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety mh (CFunction target)) | isDynamicTarget target = do -- Foreign import dynamic checkCg checkCOrAsmOrLlvmOrInterp - checkCConv cconv + cconv' <- checkCConv cconv case arg_tys of -- The first arg must be Ptr, FunPtr, or Addr [] -> do check False (illegalForeignTyErr empty sig_ty) - return idecl (arg1_ty:arg_tys) -> do dflags <- getDynFlags check (isFFIDynArgumentTy arg1_ty) (illegalForeignTyErr argument arg1_ty) checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty - return idecl + return $ CImport cconv' safety mh (CFunction target) | cconv == PrimCallConv = do dflags <- getDynFlags check (xopt Opt_GHCForeignImportPrim dflags) @@ -257,7 +254,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar return idecl | otherwise = do -- Normal foreign import checkCg checkCOrAsmOrLlvmOrDotNetOrInterp - checkCConv cconv + cconv' <- checkCConv cconv checkCTarget target dflags <- getDynFlags checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys @@ -268,7 +265,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar | not (null arg_tys) -> addErrTc (text "`value' imports cannot have function types") _ -> return () - return idecl + return $ CImport cconv' safety mh (CFunction target) -- This makes a convenient place to check @@ -315,7 +312,7 @@ tcFExport fo@(ForeignExport (L loc nm) hs_ty _ spec) (norm_co, norm_sig_ty) <- normaliseFfiType sig_ty - tcCheckFEType norm_sig_ty spec + spec' <- tcCheckFEType norm_sig_ty spec -- we're exporting a function, but at a type possibly more -- constrained than its declared/inferred type. Hence the need @@ -327,20 +324,21 @@ tcFExport fo@(ForeignExport (L loc nm) hs_ty _ spec) -- is *stable* (i.e. the compiler won't change it later), -- because this name will be referred to by the C code stub. id <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc - return (mkVarBind id rhs, ForeignExport (L loc id) undefined norm_co spec) + return (mkVarBind id rhs, ForeignExport (L loc id) undefined norm_co spec') tcFExport d = pprPanic "tcFExport" (ppr d) \end{code} ------------ Checking argument types for foreign export ---------------------- \begin{code} -tcCheckFEType :: Type -> ForeignExport -> TcM () +tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do checkCg checkCOrAsmOrLlvm check (isCLabelString str) (badCName str) - checkCConv cconv + cconv' <- checkCConv cconv checkForeignArgs isFFIExternalTy arg_tys checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty + return (CExport (CExportStatic str cconv')) where -- Drop the foralls before inspecting n -- the structure of the foreign type. @@ -449,15 +447,18 @@ checkCg check = do Calling conventions \begin{code} -checkCConv :: CCallConv -> TcM () -checkCConv CCallConv = return () -checkCConv CApiConv = return () +checkCConv :: CCallConv -> TcM CCallConv +checkCConv CCallConv = return CCallConv +checkCConv CApiConv = return CApiConv checkCConv StdCallConv = do dflags <- getDynFlags let platform = targetPlatform dflags - unless (platformArch platform == ArchX86) $ - -- This is a warning, not an error. see #3336 - addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall") -checkCConv PrimCallConv = addErrTc (text "The `prim' calling convention can only be used with `foreign import'") + if platformArch platform == ArchX86 + then return StdCallConv + else do -- This is a warning, not an error. see #3336 + addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall") + return CCallConv +checkCConv PrimCallConv = do addErrTc (text "The `prim' calling convention can only be used with `foreign import'") + return PrimCallConv checkCConv CmmCallConv = panic "checkCConv CmmCallConv" \end{code} diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 1f776cebbd..c29f1a4bc3 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -792,7 +792,7 @@ bindScopedKindVars hs_tvs thing_inside where kvs :: [KindVar] -- All skolems kvs = [ mkKindSigVar kv - | L _ (KindedTyVar _ (HsBSig _ kvs) _) <- hs_tvs + | L _ (KindedTyVar _ (HsBSig _ kvs)) <- hs_tvs , kv <- kvs ] tcHsTyVarBndrs :: [LHsTyVarBndr Name] @@ -825,7 +825,7 @@ tcHsTyVarBndr (L _ hs_tv) _ -> do { kind <- case hs_tv of UserTyVar {} -> newMetaKindVar - KindedTyVar _ (HsBSig kind _) _ -> tcLHsKind kind + KindedTyVar _ (HsBSig kind _) -> tcLHsKind kind ; return (mkTyVar name kind) } } } ------------------ @@ -915,7 +915,7 @@ kcLookupKind nm _ -> pprPanic "kcLookupKind" (ppr tc_ty_thing) } kcTyClTyVars :: Name -> [LHsTyVarBndr Name] -> (TcKind -> TcM a) -> TcM a --- Used for the type varaibles of a type or class decl, +-- Used for the type variables of a type or class decl, -- when doing the initial kind-check. kcTyClTyVars name hs_tvs thing_inside = bindScopedKindVars hs_tvs $ @@ -927,10 +927,10 @@ kcTyClTyVars name hs_tvs thing_inside ; tcExtendKindEnv name_ks (thing_inside res_k) } where kc_tv :: LHsTyVarBndr Name -> Kind -> TcM (Name, Kind) - kc_tv (L _ (UserTyVar n _)) exp_k + kc_tv (L _ (UserTyVar n)) exp_k = do { check_in_scope n exp_k ; return (n, exp_k) } - kc_tv (L _ (KindedTyVar n (HsBSig hs_k _) _)) exp_k + kc_tv (L _ (KindedTyVar n (HsBSig hs_k _))) exp_k = do { k <- tcLHsKind hs_k ; _ <- unifyKind k exp_k ; check_in_scope n exp_k diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index c166e6210e..b2b4089f54 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -431,13 +431,14 @@ kcFamilyDecl (TySynonym {}) = return () kcFamilyDecl d = pprPanic "kcFamilyDecl" (ppr d) ------------------ -kcResultKind :: Maybe (LHsKind Name) -> Kind -> TcM () +kcResultKind :: Maybe (HsBndrSig (LHsKind Name)) -> Kind -> TcM () kcResultKind Nothing res_k = discardResult (unifyKind res_k liftedTypeKind) -- type family F a -- defaults to type family F a :: * -kcResultKind (Just k) res_k - = do { k' <- tcLHsKind k +kcResultKind (Just (HsBSig k ns)) res_k + = do { let kvs = map mkKindSigVar ns + ; k' <- tcExtendTyVarEnv kvs (tcLHsKind k) ; discardResult (unifyKind k' res_k) } \end{code} diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index 6b99a1f53b..e9af2015ba 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -1176,7 +1176,7 @@ isOverloadedTy _ = False \begin{code} isFloatTy, isDoubleTy, isIntegerTy, isIntTy, isWordTy, isBoolTy, - isUnitTy, isCharTy :: Type -> Bool + isUnitTy, isCharTy, isAnyTy :: Type -> Bool isFloatTy = is_tc floatTyConKey isDoubleTy = is_tc doubleTyConKey isIntegerTy = is_tc integerTyConKey @@ -1185,6 +1185,7 @@ isWordTy = is_tc wordTyConKey isBoolTy = is_tc boolTyConKey isUnitTy = is_tc unitTyConKey isCharTy = is_tc charTyConKey +isAnyTy = is_tc anyTyConKey isStringTy :: Type -> Bool isStringTy ty @@ -1354,9 +1355,11 @@ isFFILabelTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey] isFFIPrimArgumentTy :: DynFlags -> Type -> Bool -- Checks for valid argument type for a 'foreign import prim' --- Currently they must all be simple unlifted types. +-- Currently they must all be simple unlifted types, or the well-known type +-- Any, which can be used to pass the address to a Haskell object on the heap to +-- the foreign function. isFFIPrimArgumentTy dflags ty - = checkRepTyCon (legalFIPrimArgTyCon dflags) ty + = isAnyTy ty || checkRepTyCon (legalFIPrimArgTyCon dflags) ty isFFIPrimResultTy :: DynFlags -> Type -> Bool -- Checks for valid result type for a 'foreign import prim' diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index 931bdf78ad..c7b9dedd37 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -414,7 +414,6 @@ lookupFamInstEnvConflicts envs fam_inst skol_tvs (ppr tpl_tvs <+> ppr tpl_tys) ) -- Unification will break badly if the variables overlap -- They shouldn't because we allocate separate uniques for them - pprTrace "tcUnifyTys" (ppr tpl_tys $$ ppr match_tys $$ ppr fam_inst) $ case tcUnifyTys instanceBindFun tpl_tys match_tys of Just subst | conflicting old_fam_inst subst -> Just subst _other -> Nothing diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index b96ae5e063..b58fcd4817 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -958,10 +958,9 @@ warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x warnPprTrace False _file _line _msg x = x warnPprTrace True file line msg x - = pprDebugAndThen trace "WARNING:" doc x + = pprDebugAndThen trace str msg x where - doc = sep [hsep [text "WARNING: file", text file, text "line", int line], - msg] + str = showSDoc (hsep [text "WARNING: file", text file <> comma, text "line", int line]) assertPprPanic :: String -> Int -> SDoc -> a -- ^ Panic with an assertation failure, recording the given file and line number. diff --git a/configure.ac b/configure.ac index 4951467b4d..b796f6d441 100644 --- a/configure.ac +++ b/configure.ac @@ -159,9 +159,9 @@ fi; # GHC is passed to Cabal, so we need a native path if test "${WithGhc}" != "" then - ghc_host=`"${WithGhc}" +RTS --info | grep 'Host platform' | sed -e 's/.*, "//' -e 's/")//'` + ghc_host_os=`"${WithGhc}" +RTS --info | grep 'Host OS' | sed -e 's/.*, "//' -e 's/")//'` - if test "$ghc_host" = "i386-unknown-mingw32" + if test "$ghc_host_os" = "mingw32" then if test "${OSTYPE}" = "msys" then @@ -252,57 +252,73 @@ if test "$HostOS" = "mingw32" then test -d inplace || mkdir inplace - CC="$hardtop/inplace/mingw/bin/gcc.exe" - LD="$hardtop/inplace/mingw/bin/ld.exe" - NM="$hardtop/inplace/mingw/bin/nm.exe" - fp_prog_ar_raw="$hardtop/inplace/mingw/bin/ar.exe" - - # NB. If you update the tarballs to a new version of gcc, don't - # forget to tweak the paths in driver/gcc/gcc.c. - if ! test -d inplace/mingw || - test inplace/mingw -ot ghc-tarballs/mingw/binutils*.tar.lzma || - test inplace/mingw -ot ghc-tarballs/mingw/gcc-core*.tar.lzma || - test inplace/mingw -ot ghc-tarballs/mingw/gcc-c++*.tar.lzma || - test inplace/mingw -ot ghc-tarballs/mingw/libgcc*.tar.gz || - test inplace/mingw -ot ghc-tarballs/mingw/libgmp*.tar.gz || - test inplace/mingw -ot ghc-tarballs/mingw/libmpc*.tar.gz || - test inplace/mingw -ot ghc-tarballs/mingw/libmpfr*.tar.gz || - test inplace/mingw -ot ghc-tarballs/mingw/libstdc*.tar.lzma || - test inplace/mingw -ot ghc-tarballs/mingw/mingwrt*-dev.tar.gz || - test inplace/mingw -ot ghc-tarballs/mingw/mingwrt*-dll.tar.gz || - test inplace/mingw -ot ghc-tarballs/mingw/w32api*.tar.lzma + if test "$HostArch" = "i386" then - AC_MSG_NOTICE([Making in-tree mingw tree]) - rm -rf inplace/mingw - mkdir inplace/mingw - ( - cd inplace/mingw && - tar --lzma -xf ../../ghc-tarballs/mingw/binutils*.tar.lzma && - tar --lzma -xf ../../ghc-tarballs/mingw/gcc-core*.tar.lzma && - tar --lzma -xf ../../ghc-tarballs/mingw/gcc-c++*.tar.lzma && - tar --lzma -xf ../../ghc-tarballs/mingw/libgcc*.tar.lzma && - tar --lzma -xf ../../ghc-tarballs/mingw/libgmp*.tar.lzma && - tar --lzma -xf ../../ghc-tarballs/mingw/libmpc*.tar.lzma && - tar --lzma -xf ../../ghc-tarballs/mingw/libmpfr*.tar.lzma && - tar --lzma -xf ../../ghc-tarballs/mingw/libstdc*.tar.lzma && - tar -z -xf ../../ghc-tarballs/mingw/mingwrt*-dev.tar.gz && - tar -z -xf ../../ghc-tarballs/mingw/mingwrt*-dll.tar.gz && - tar --lzma -xf ../../ghc-tarballs/mingw/w32api*.tar.lzma && - mv bin/gcc.exe bin/realgcc.exe - ) - PATH=`pwd`/inplace/mingw/bin:$PATH inplace/mingw/bin/realgcc.exe driver/gcc/gcc.c driver/utils/cwrapper.c driver/utils/getLocation.c -Idriver/utils -o inplace/mingw/bin/gcc.exe - if ! test -e inplace/mingw/bin/gcc.exe + # NB. If you update the tarballs to a new version of gcc, don't + # forget to tweak the paths in driver/gcc/gcc.c. + if ! test -d inplace/mingw || + test inplace/mingw -ot ghc-tarballs/mingw/binutils*.tar.lzma || + test inplace/mingw -ot ghc-tarballs/mingw/gcc-core*.tar.lzma || + test inplace/mingw -ot ghc-tarballs/mingw/gcc-c++*.tar.lzma || + test inplace/mingw -ot ghc-tarballs/mingw/libgcc*.tar.gz || + test inplace/mingw -ot ghc-tarballs/mingw/libgmp*.tar.gz || + test inplace/mingw -ot ghc-tarballs/mingw/libmpc*.tar.gz || + test inplace/mingw -ot ghc-tarballs/mingw/libmpfr*.tar.gz || + test inplace/mingw -ot ghc-tarballs/mingw/libstdc*.tar.lzma || + test inplace/mingw -ot ghc-tarballs/mingw/mingwrt*-dev.tar.gz || + test inplace/mingw -ot ghc-tarballs/mingw/mingwrt*-dll.tar.gz || + test inplace/mingw -ot ghc-tarballs/mingw/w32api*.tar.lzma + then + AC_MSG_NOTICE([Making in-tree mingw tree]) + rm -rf inplace/mingw + mkdir inplace/mingw + ( + cd inplace/mingw && + tar --lzma -xf ../../ghc-tarballs/mingw/binutils*.tar.lzma && + tar --lzma -xf ../../ghc-tarballs/mingw/gcc-core*.tar.lzma && + tar --lzma -xf ../../ghc-tarballs/mingw/gcc-c++*.tar.lzma && + tar --lzma -xf ../../ghc-tarballs/mingw/libgcc*.tar.lzma && + tar --lzma -xf ../../ghc-tarballs/mingw/libgmp*.tar.lzma && + tar --lzma -xf ../../ghc-tarballs/mingw/libmpc*.tar.lzma && + tar --lzma -xf ../../ghc-tarballs/mingw/libmpfr*.tar.lzma && + tar --lzma -xf ../../ghc-tarballs/mingw/libstdc*.tar.lzma && + tar -z -xf ../../ghc-tarballs/mingw/mingwrt*-dev.tar.gz && + tar -z -xf ../../ghc-tarballs/mingw/mingwrt*-dll.tar.gz && + tar --lzma -xf ../../ghc-tarballs/mingw/w32api*.tar.lzma && + mv bin/gcc.exe bin/realgcc.exe + ) + PATH=`pwd`/inplace/mingw/bin:$PATH inplace/mingw/bin/realgcc.exe driver/gcc/gcc.c driver/utils/cwrapper.c driver/utils/getLocation.c -Idriver/utils -o inplace/mingw/bin/gcc.exe + AC_MSG_NOTICE([In-tree mingw tree created]) + fi + mingwbin="$hardtop/inplace/mingw/bin/" + else + # NB. If you update the tarballs to a new version of gcc, don't + # forget to tweak the paths in driver/gcc/gcc.c. + if ! test -d inplace/mingw || + test inplace/mingw -ot ghc-tarballs/mingw64/mingw-w64-bin_*.zip then - AC_MSG_ERROR([GHC is required unless bootstrapping from .hc files.]) + AC_MSG_NOTICE([Making in-tree mingw tree]) + rm -rf inplace/mingw + mkdir inplace/mingw + ( + cd inplace/mingw && + unzip ../../ghc-tarballs/mingw64/mingw-w64-bin_*.zip + ) + AC_MSG_NOTICE([In-tree mingw tree created]) fi - AC_MSG_NOTICE([In-tree mingw tree created]) + mingwbin="$hardtop/inplace/mingw/bin/x86_64-w64-mingw32-" fi + + CC="${mingwbin}gcc.exe" + LD="${mingwbin}ld.exe" + NM="${mingwbin}nm.exe" + fp_prog_ar_raw="${mingwbin}ar.exe" + if ! test -d inplace/perl || test inplace/perl -ot ghc-tarballs/perl/ghc-perl*.tar.gz then AC_MSG_NOTICE([Making in-tree perl tree]) rm -rf inplace/perl - mkdir inplace mkdir inplace/perl ( cd inplace/perl && @@ -447,10 +463,11 @@ dnl -------------------------------------------------------------- dnl ** Can the unix package be built? dnl -------------------------------------------------------------- -if test x"$TargetPlatform" = x"i386-unknown-mingw32"; then - GhcLibsWithUnix=NO +if test "$TargetOS" = "mingw32" +then + GhcLibsWithUnix=NO else - GhcLibsWithUnix=YES + GhcLibsWithUnix=YES fi AC_SUBST([GhcLibsWithUnix]) @@ -571,9 +588,9 @@ AC_SUBST(HaveDtrace) AC_PATH_PROG(HSCOLOUR,HsColour) # HsColour is passed to Cabal, so we need a native path -if test "x$HostPlatform" = "xi386-unknown-mingw32" && \ - test "${OSTYPE}" != "msys" && \ - test "${HSCOLOUR}" != "" +if test "$HostOS" = "mingw32" && \ + test "${OSTYPE}" != "msys" && \ + test "${HSCOLOUR}" != "" then # Canonicalise to <drive>:/path/to/gcc HSCOLOUR=`cygpath -m ${HSCOLOUR}` diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index bcf84b4246..d7e200458d 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -2025,16 +2025,6 @@ The following syntax is stolen: <varlistentry> <term> - <literal>'<replaceable>varid</replaceable></literal> - </term> - <listitem><para> - Stolen by: <option>-XTemplateHaskell</option>and - <option>-XPolyKinds</option> - </para></listitem> - </varlistentry> - - <varlistentry> - <term> <literal>[:<replaceable>varid</replaceable>|</literal> <indexterm><primary>quasi-quotation</primary></indexterm> </term> @@ -5356,8 +5346,11 @@ type T1 = P -- 1 type T2 = 'P -- promoted 2 </programlisting> Note that promoted datatypes give rise to named kinds. Since these can never be -ambiguous, we do not allow quotes in kind names. +ambiguous, we do not allow quotes in kind names. </para> +<para>Just as in the case of Template Haskell (<xref linkend="th-syntax"/>), there is +no way to quote a data constructor or type constructor whose second character +is a single quote.</para> </sect3> <sect3 id="promoted-lists-and-tuples"> @@ -6871,7 +6864,7 @@ understand Template Haskell; see the <ulink url="http://haskell.org/haskellwiki/ Wiki page</ulink>. </para> - <sect2> + <sect2 id="th-syntax"> <title>Syntax</title> <para> Template Haskell has the following new syntactic @@ -6931,7 +6924,19 @@ Wiki page</ulink>. <itemizedlist> <listitem><para> <literal>'f</literal> has type <literal>Name</literal>, and names the function <literal>f</literal>. Similarly <literal>'C</literal> has type <literal>Name</literal> and names the data constructor <literal>C</literal>. - In general <literal>'</literal><replaceable>thing</replaceable> interprets <replaceable>thing</replaceable> in an expression context. + In general <literal>'</literal><replaceable>thing</replaceable> + interprets <replaceable>thing</replaceable> in an expression context.</para> + <para>A name whose second character is a single + quote (sadly) cannot be quoted in this way, + because it will be parsed instead as a quoted + character. For example, if the function is called + <literal>f'7</literal> (which is a legal Haskell + identifier), an attempt to quote it as + <literal>'f'7</literal> would be parsed as the + character literal <literal>'f'</literal> followed + by the numeric literal <literal>7</literal>. There + is no current escape mechanism in this (unusual) + situation. </para></listitem> <listitem><para> <literal>''T</literal> has type <literal>Name</literal>, and names the type constructor <literal>T</literal>. That is, <literal>''</literal><replaceable>thing</replaceable> interprets <replaceable>thing</replaceable> in a type context. diff --git a/driver/ghci/ghc.mk b/driver/ghci/ghc.mk index 51203ab4d5..88c6aafeca 100644 --- a/driver/ghci/ghc.mk +++ b/driver/ghci/ghc.mk @@ -34,14 +34,14 @@ driver/ghci_dist_PROG = ghci$(exeext) driver/ghci_dist_INSTALL = YES driver/ghci_dist_OTHER_OBJS = driver/ghci/ghci.res -$(eval $(call build-prog,driver/ghci,dist,0)) +$(eval $(call build-prog,driver/ghci,dist,1)) driver/ghci_dist_PROG_VER = ghci-$(ProjectVersion)$(exeext) INSTALL_BINS += driver/ghci/dist/build/tmp/$(driver/ghci_dist_PROG_VER) driver/ghci/ghci.res : driver/ghci/ghci.rc driver/ghci/ghci.ico - $(INPLACE_MINGW)/bin/windres --preprocessor="$(CPP) -xc -DRC_INVOKED" -o driver/ghci/ghci.res -i driver/ghci/ghci.rc -O coff + "$(WINDRES)" --preprocessor="$(CPP) -xc -DRC_INVOKED" -o driver/ghci/ghci.res -i driver/ghci/ghci.rc -O coff driver/ghci/dist/build/tmp/$(driver/ghci_dist_PROG_VER) : driver/ghci/dist/build/tmp/$(driver/ghci_dist_PROG) "$(CP)" $< $@ diff --git a/driver/utils/cwrapper.c b/driver/utils/cwrapper.c index 911290224c..5105924b74 100644 --- a/driver/utils/cwrapper.c +++ b/driver/utils/cwrapper.c @@ -31,7 +31,7 @@ char *mkString(const char *fmt, ...) { va_end(argp); if (i < 0) { - die("snprintf 0 failed: errno %d: %s\n", errno, strerror(errno)); + die("vsnprintf 0 failed: errno %d: %s\n", errno, strerror(errno)); } p = malloc(i + 1); @@ -42,8 +42,8 @@ char *mkString(const char *fmt, ...) { va_start(argp, fmt); j = vsnprintf(p, i + 1, fmt, argp); va_end(argp); - if (i < 0) { - die("snprintf with %d failed: errno %d: %s\n", + if (j < 0) { + die("vsnprintf with %d failed: errno %d: %s\n", i + 1, errno, strerror(errno)); } diff --git a/ghc/ghc.mk b/ghc/ghc.mk index ede5687dc6..a13f03b875 100644 --- a/ghc/ghc.mk +++ b/ghc/ghc.mk @@ -22,6 +22,15 @@ ghc_stage2_CONFIGURE_OPTS += --flags=ghci ghc_stage3_CONFIGURE_OPTS += --flags=ghci endif +ifeq "$(compiler_stage1_VERSION_MUNGED)" "YES" +# If we munge the stage1 version, and we're using a devel snapshot for +# stage0, then stage1 may actually have an earlier version than stage0 +# (e.g. boot with ghc-7.5.20120316, building ghc-7.5). We therefore +# need to tell Cabal to use version 7.5 of the ghc package when building +# in ghc/stage1 +ghc_stage1_CONFIGURE_OPTS += --constraint "ghc == $(compiler_stage1_MUNGED_VERSION)" +endif + ghc_stage1_MORE_HC_OPTS = $(GhcStage1HcOpts) ghc_stage2_MORE_HC_OPTS = $(GhcStage2HcOpts) ghc_stage3_MORE_HC_OPTS = $(GhcStage3HcOpts) diff --git a/includes/Cmm.h b/includes/Cmm.h index 11c02b4e3e..f582ca9771 100644 --- a/includes/Cmm.h +++ b/includes/Cmm.h @@ -383,7 +383,7 @@ // allocate() - this includes many of the primops. #define MAYBE_GC(liveness,reentry) \ if (bdescr_link(CurrentNursery) == NULL || \ - generation_n_new_large_words(W_[g0]) >= CLong[large_alloc_lim]) { \ + generation_n_new_large_words(W_[g0]) >= TO_W_(CLong[large_alloc_lim])) { \ R9 = liveness; \ R10 = reentry; \ HpAlloc = 0; \ diff --git a/includes/HaskellConstants.hs b/includes/HaskellConstants.hs index e38e896ba0..ef38cb5788 100644 --- a/includes/HaskellConstants.hs +++ b/includes/HaskellConstants.hs @@ -176,6 +176,12 @@ mAX_PTR_TAG = tAG_MASK cINT_SIZE :: Int cINT_SIZE = SIZEOF_INT +cLONG_SIZE :: Int +cLONG_SIZE = SIZEOF_LONG + +cLONG_LONG_SIZE :: Int +cLONG_LONG_SIZE = SIZEOF_LONG_LONG + -- Size of a storage manager block (in bytes). bLOCK_SIZE :: Int diff --git a/includes/MachDeps.h b/includes/MachDeps.h index f97d3e87d4..81e223dfb5 100644 --- a/includes/MachDeps.h +++ b/includes/MachDeps.h @@ -83,19 +83,18 @@ #define SIZEOF_WORD32 SIZEOF_UNSIGNED_INT #define ALIGNMENT_WORD32 ALIGNMENT_UNSIGNED_INT -#if HAVE_LONG_LONG && SIZEOF_VOID_P < 8 -/* assume long long is 64 bits */ -#define SIZEOF_INT64 SIZEOF_LONG_LONG -#define ALIGNMENT_INT64 ALIGNMENT_LONG_LONG -#define SIZEOF_WORD64 SIZEOF_UNSIGNED_LONG_LONG -#define ALIGNMENT_WORD64 ALIGNMENT_UNSIGNED_LONG_LONG -#elif SIZEOF_LONG == 8 +#if SIZEOF_LONG == 8 #define SIZEOF_INT64 SIZEOF_LONG #define ALIGNMENT_INT64 ALIGNMENT_LONG #define SIZEOF_WORD64 SIZEOF_UNSIGNED_LONG #define ALIGNMENT_WORD64 ALIGNMENT_UNSIGNED_LONG +#elif HAVE_LONG_LONG && SIZEOF_LONG_LONG == 8 +#define SIZEOF_INT64 SIZEOF_LONG_LONG +#define ALIGNMENT_INT64 ALIGNMENT_LONG_LONG +#define SIZEOF_WORD64 SIZEOF_UNSIGNED_LONG_LONG +#define ALIGNMENT_WORD64 ALIGNMENT_UNSIGNED_LONG_LONG #else -#error GHC untested on this architecture: sizeof(void *) < 8 and no long longs. +#error Cannot find a 64bit type. #endif #ifndef WORD_SIZE_IN_BITS diff --git a/includes/Rts.h b/includes/Rts.h index 3360eda323..cb23fd1083 100644 --- a/includes/Rts.h +++ b/includes/Rts.h @@ -17,6 +17,13 @@ extern "C" { #endif +/* We include windows.h very early, as on Win64 the CONTEXT type has + fields "R8", "R9" and "R10", which goes bad if we've already + #define'd those names for our own purposes (in stg/Regs.h) */ +#if defined(HAVE_WINDOWS_H) +#include <windows.h> +#endif + #ifndef IN_STG_CODE #define IN_STG_CODE 0 #endif diff --git a/includes/RtsAPI.h b/includes/RtsAPI.h index e3b3f7d5f5..7f41ebc421 100644 --- a/includes/RtsAPI.h +++ b/includes/RtsAPI.h @@ -232,7 +232,7 @@ SchedulerStatus rts_getSchedStatus (Capability *cap); // Note that RtsAPI.h is also included by foreign export stubs in // the base package itself. // -#if defined(mingw32_HOST_OS) && defined(__PIC__) && !defined(COMPILING_BASE_PACKAGE) +#if defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH) && defined(__PIC__) && !defined(COMPILING_BASE_PACKAGE) __declspec(dllimport) extern StgWord base_GHCziTopHandler_runIO_closure[]; __declspec(dllimport) extern StgWord base_GHCziTopHandler_runNonIO_closure[]; #else diff --git a/includes/rts/storage/InfoTables.h b/includes/rts/storage/InfoTables.h index e4397f2ee3..3fbeed2450 100644 --- a/includes/rts/storage/InfoTables.h +++ b/includes/rts/storage/InfoTables.h @@ -77,7 +77,7 @@ typedef struct { /* The type flags provide quick access to certain properties of a closure. */ #define _HNF (1<<0) /* head normal form? */ -#define _BTM (1<<1) /* bitmap-style layout? */ +#define _BTM (1<<1) /* uses info->layout.bitmap */ #define _NS (1<<2) /* non-sparkable */ #define _STA (1<<3) /* static? */ #define _THU (1<<4) /* thunk? */ diff --git a/includes/stg/DLL.h b/includes/stg/DLL.h index 7d4096025d..b7030b0e88 100644 --- a/includes/stg/DLL.h +++ b/includes/stg/DLL.h @@ -14,7 +14,7 @@ #ifndef __STGDLL_H__ #define __STGDLL_H__ 1 -#if defined(__PIC__) && defined(mingw32_HOST_OS) +#if defined(__PIC__) && defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH) # define DLL_IMPORT_DATA_REF(x) (_imp__##x) # define DLL_IMPORT_DATA_VARNAME(x) *_imp__##x # if __GNUC__ && !defined(__declspec) @@ -45,7 +45,7 @@ #else #define DLL_IMPORT #define DLL_IMPORT_RTS DLLIMPORT -# if defined(__PIC__) && defined(mingw32_HOST_OS) +# if defined(__PIC__) && defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH) # define DLL_IMPORT_DATA_VAR(x) _imp__##x # else # define DLL_IMPORT_DATA_VAR(x) x diff --git a/mk/config.mk.in b/mk/config.mk.in index 2b5bd46aba..2482da869d 100644 --- a/mk/config.mk.in +++ b/mk/config.mk.in @@ -622,6 +622,12 @@ ifeq "$(CrossCompiling)" "YES" SRC_HSC2HS_OPTS += --cross-compile endif +ifeq "$(TARGETPLATFORM)" "i386-unknown-mingw32" +WINDRES = $(INPLACE_MINGW)/bin/windres +else ifeq "$(TARGETPLATFORM)" "x86_64-unknown-mingw32" +WINDRES = $(INPLACE_MINGW)/bin/x86_64-w64-mingw32-windres +endif + #----------------------------------------------------------------------------- # Mingwex Library # diff --git a/rts/ClosureFlags.c b/rts/ClosureFlags.c index 41810f4025..0ab8b45669 100644 --- a/rts/ClosureFlags.c +++ b/rts/ClosureFlags.c @@ -37,14 +37,14 @@ StgWord16 closure_flags[] = { [FUN_1_1] = (_HNF| _NS| _SRT ), [FUN_0_2] = (_HNF| _NS| _SRT ), [FUN_STATIC] = (_HNF| _NS|_STA| _SRT ), - [THUNK] = ( _BTM| _THU| _SRT ), - [THUNK_1_0] = ( _BTM| _THU| _SRT ), - [THUNK_0_1] = ( _BTM| _THU| _SRT ), - [THUNK_2_0] = ( _BTM| _THU| _SRT ), - [THUNK_1_1] = ( _BTM| _THU| _SRT ), - [THUNK_0_2] = ( _BTM| _THU| _SRT ), - [THUNK_STATIC] = ( _BTM| _STA|_THU| _SRT ), - [THUNK_SELECTOR] = ( _BTM| _THU| _SRT ), + [THUNK] = ( _THU| _SRT ), + [THUNK_1_0] = ( _THU| _SRT ), + [THUNK_0_1] = ( _THU| _SRT ), + [THUNK_2_0] = ( _THU| _SRT ), + [THUNK_1_1] = ( _THU| _SRT ), + [THUNK_0_2] = ( _THU| _SRT ), + [THUNK_STATIC] = ( _STA|_THU| _SRT ), + [THUNK_SELECTOR] = ( _THU| _SRT ), [BCO] = (_HNF| _NS ), [AP] = ( _THU ), [PAP] = (_HNF| _NS ), @@ -52,7 +52,7 @@ StgWord16 closure_flags[] = { [IND] = ( _NS| _IND ), [IND_PERM] = ( _NS| _IND ), [IND_STATIC] = ( _NS|_STA| _IND ), - [RET_BCO] = ( _BTM ), + [RET_BCO] = ( 0 ), [RET_SMALL] = ( _BTM| _SRT ), [RET_BIG] = ( _SRT ), [RET_DYN] = ( _SRT ), diff --git a/rts/HeapStackCheck.cmm b/rts/HeapStackCheck.cmm index 74545af149..199f0cd378 100644 --- a/rts/HeapStackCheck.cmm +++ b/rts/HeapStackCheck.cmm @@ -676,13 +676,19 @@ INFO_TABLE_RET( stg_block_async, RET_SMALL, W_ unused ) W_ len, errC; ares = Sp(1); - len = StgAsyncIOResult_len(ares); - errC = StgAsyncIOResult_errCode(ares); + len = TO_W_(StgAsyncIOResult_len(ares)); + errC = TO_W_(StgAsyncIOResult_errCode(ares)); foreign "C" free(ares "ptr"); +#ifdef GhcUnregisterised + Sp(1) = errC; + Sp(0) = len; + jump %ENTRY_CODE(Sp(2)); +#else R1 = len; Sp_adj(1); Sp(0) = errC; jump %ENTRY_CODE(Sp(1)); +#endif } stg_block_async diff --git a/rts/Interpreter.c b/rts/Interpreter.c index 2eac1cd834..a18e7caa8d 100644 --- a/rts/Interpreter.c +++ b/rts/Interpreter.c @@ -31,9 +31,11 @@ // When building the RTS in the non-dyn way on Windows, we don't // want declspec(__dllimport__) on the front of function prototypes // from libffi. -#if defined(mingw32_HOST_OS) && !defined(__PIC__) +#if defined(mingw32_HOST_OS) +#if (defined(i386_HOST_ARCH) && !defined(__PIC__)) || defined(x86_64_HOST_ARCH) # define LIBFFI_NOT_DLL #endif +#endif #include "ffi.h" diff --git a/rts/Linker.c b/rts/Linker.c index 9fb3f68fb9..6fd36d8bd8 100644 --- a/rts/Linker.c +++ b/rts/Linker.c @@ -396,10 +396,7 @@ typedef struct _RtsSymbolVal { SymI_HasProto(utime) \ SymI_HasProto(waitpid) -#elif !defined(mingw32_HOST_OS) -#define RTS_MINGW_ONLY_SYMBOLS /**/ -#define RTS_CYGWIN_ONLY_SYMBOLS /**/ -#else /* defined(mingw32_HOST_OS) */ +#elif defined(mingw32_HOST_OS) #define RTS_POSIX_ONLY_SYMBOLS /**/ #define RTS_CYGWIN_ONLY_SYMBOLS /**/ @@ -415,6 +412,12 @@ typedef struct _RtsSymbolVal { #define RTS___MINGW_VFPRINTF_SYM /**/ #endif +#if defined(i386_HOST_ARCH) +#define RTS_MINGW32_ONLY(X) X +#else +#define RTS_MINGW32_ONLY(X) /**/ +#endif + /* These are statically linked from the mingw libraries into the ghc executable, so we have to employ this hack. */ #define RTS_MINGW_ONLY_SYMBOLS \ @@ -444,7 +447,7 @@ typedef struct _RtsSymbolVal { SymI_HasProto(strcpy) \ SymI_HasProto(strncpy) \ SymI_HasProto(abort) \ - SymI_NeedsProto(_alloca) \ + RTS_MINGW32_ONLY(SymI_NeedsProto(_alloca)) \ SymI_HasProto(isxdigit) \ SymI_HasProto(isupper) \ SymI_HasProto(ispunct) \ @@ -495,21 +498,25 @@ typedef struct _RtsSymbolVal { SymI_HasProto(rts_InstallConsoleEvent) \ SymI_HasProto(rts_ConsoleHandlerDone) \ SymI_NeedsProto(mktime) \ - SymI_NeedsProto(_imp___timezone) \ - SymI_NeedsProto(_imp___tzname) \ - SymI_NeedsProto(_imp__tzname) \ - SymI_NeedsProto(_imp___iob) \ - SymI_NeedsProto(_imp___osver) \ + RTS_MINGW32_ONLY(SymI_NeedsProto(_imp___timezone)) \ + RTS_MINGW32_ONLY(SymI_NeedsProto(_imp___tzname)) \ + RTS_MINGW32_ONLY(SymI_NeedsProto(_imp__tzname)) \ + RTS_MINGW32_ONLY(SymI_NeedsProto(_imp___iob)) \ + RTS_MINGW32_ONLY(SymI_NeedsProto(_imp___osver)) \ SymI_NeedsProto(localtime) \ SymI_NeedsProto(gmtime) \ SymI_NeedsProto(opendir) \ SymI_NeedsProto(readdir) \ SymI_NeedsProto(rewinddir) \ - SymI_NeedsProto(_imp____mb_cur_max) \ - SymI_NeedsProto(_imp___pctype) \ - SymI_NeedsProto(__chkstk) \ + RTS_MINGW32_ONLY(SymI_NeedsProto(_imp____mb_cur_max)) \ + RTS_MINGW32_ONLY(SymI_NeedsProto(_imp___pctype)) \ + RTS_MINGW32_ONLY(SymI_NeedsProto(__chkstk)) \ RTS_MINGW_GETTIMEOFDAY_SYM \ SymI_NeedsProto(closedir) + +#else +#define RTS_MINGW_ONLY_SYMBOLS /**/ +#define RTS_CYGWIN_ONLY_SYMBOLS /**/ #endif @@ -742,7 +749,7 @@ typedef struct _RtsSymbolVal { // We don't do this when compiling to Windows DLLs at the moment because // it doesn't support cross package data references well. // -#if defined(__PIC__) && defined(mingw32_HOST_OS) +#if defined(__PIC__) && defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH) #define RTS_INTCHAR_SYMBOLS #else #define RTS_INTCHAR_SYMBOLS \ @@ -1069,7 +1076,7 @@ typedef struct _RtsSymbolVal { /* entirely bogus claims about types of these symbols */ #define SymI_NeedsProto(vvv) extern void vvv(void); -#if defined(__PIC__) && defined(mingw32_HOST_OS) +#if defined(__PIC__) && defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH) #define SymE_HasProto(vvv) SymE_HasProto(vvv); #define SymE_NeedsProto(vvv) extern void _imp__ ## vvv (void); #else diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm index 4cb3b8d85c..e368ed195b 100644 --- a/rts/PrimOps.cmm +++ b/rts/PrimOps.cmm @@ -35,7 +35,7 @@ import base_ControlziExceptionziBase_nestedAtomically_closure; import EnterCriticalSection; import LeaveCriticalSection; import ghczmprim_GHCziTypes_False_closure; -#if !defined(mingw32_HOST_OS) +#if defined(GhcUnregisterised) || !defined(mingw32_HOST_OS) import sm_mutex; #endif diff --git a/rts/Printer.c b/rts/Printer.c index 008427113a..688ed7b664 100644 --- a/rts/Printer.c +++ b/rts/Printer.c @@ -1107,8 +1107,8 @@ char *closure_type_names[] = { [CATCH_FRAME] = "CATCH_FRAME", [UNDERFLOW_FRAME] = "UNDERFLOW_FRAME", [STOP_FRAME] = "STOP_FRAME", - [BLACKHOLE] = "BLACKHOLE", [BLOCKING_QUEUE] = "BLOCKING_QUEUE", + [BLACKHOLE] = "BLACKHOLE", [MVAR_CLEAN] = "MVAR_CLEAN", [MVAR_DIRTY] = "MVAR_DIRTY", [ARR_WORDS] = "ARR_WORDS", diff --git a/rts/RtsMain.c b/rts/RtsMain.c index e89445db25..435df420c5 100644 --- a/rts/RtsMain.c +++ b/rts/RtsMain.c @@ -108,11 +108,11 @@ int hs_main (int argc, char *argv[], // program args progmain_closure = main_closure; rtsconfig = rts_config; -#if defined(mingw32_HOST_OS) +#if defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH) BEGIN_CATCH #endif real_main(); -#if defined(mingw32_HOST_OS) +#if defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH) END_CATCH #endif } diff --git a/rts/Schedule.c b/rts/Schedule.c index e17116bc07..aa22e06bd9 100644 --- a/rts/Schedule.c +++ b/rts/Schedule.c @@ -611,7 +611,7 @@ schedulePreLoop(void) { // initialisation for scheduler - what cannot go into initScheduler() -#if defined(mingw32_HOST_OS) +#if defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH) && !defined(GhcUnregisterised) win32AllocStack(); #endif } diff --git a/rts/StgCRun.c b/rts/StgCRun.c index 3654b3336a..f08e35dd11 100644 --- a/rts/StgCRun.c +++ b/rts/StgCRun.c @@ -33,6 +33,14 @@ /* include Stg.h first because we want real machine regs in here: we * have to get the value of R1 back from Stg land to C land intact. */ + +/* We include windows.h very early, as on Win64 the CONTEXT type has + fields "R8", "R9" and "R10", which goes bad if we've already + #define'd those names for our own purposes (in stg/Regs.h) */ +#if defined(HAVE_WINDOWS_H) +#include <windows.h> +#endif + #define IN_STGCRUN 1 #include "Stg.h" #include "Rts.h" diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm index e4b128f96e..763c85b3b6 100644 --- a/rts/StgMiscClosures.cmm +++ b/rts/StgMiscClosures.cmm @@ -576,7 +576,7 @@ INFO_TABLE_CONSTR(stg_MVAR_TSO_QUEUE,2,0,0,PRIM,"MVAR_TSO_QUEUE","MVAR_TSO_QUEUE replace them with references to the static objects. ------------------------------------------------------------------------- */ -#if defined(__PIC__) && defined(mingw32_HOST_OS) +#if defined(__PIC__) && defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH) /* * When sticking the RTS in a Windows DLL, we delay populating the * Charlike and Intlike tables until load-time, which is only @@ -601,7 +601,7 @@ INFO_TABLE_CONSTR(stg_MVAR_TSO_QUEUE,2,0,0,PRIM,"MVAR_TSO_QUEUE","MVAR_TSO_QUEUE * on the fact that static closures live in the data section. */ -#if !(defined(__PIC__) && defined(mingw32_HOST_OS)) +#if !(defined(__PIC__) && defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH)) section "data" { stg_CHARLIKE_closure: CHARLIKE_HDR(0) @@ -899,4 +899,4 @@ section "data" { INTLIKE_HDR(16) /* MAX_INTLIKE == 16 */ } -#endif // !(defined(__PIC__) && defined(mingw32_HOST_OS)) +#endif // !(defined(__PIC__) && defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH)) diff --git a/rts/ghc.mk b/rts/ghc.mk index fc634c7ff2..e5fff56008 100644 --- a/rts/ghc.mk +++ b/rts/ghc.mk @@ -28,7 +28,7 @@ all_rts : $(ALL_RTS_LIBS) ALL_DIRS = hooks parallel sm eventlog -ifeq "$(HOSTPLATFORM)" "i386-unknown-mingw32" +ifeq "$(HostOS_CPP)" "mingw32" ALL_DIRS += win32 else ALL_DIRS += posix @@ -311,6 +311,12 @@ rts/RtsUtils_CC_OPTS += -DTargetVendor=\"$(TargetVendor_CPP)\" rts/RtsUtils_CC_OPTS += -DGhcUnregisterised=\"$(GhcUnregisterised)\" rts/RtsUtils_CC_OPTS += -DGhcEnableTablesNextToCode=\"$(GhcEnableTablesNextToCode)\" +ifeq "$(GhcUnregisterised)" "YES" +rts/HeapStackCheck_HC_OPTS += -DGhcUnregisterised=1 +rts/PrimOps_HC_OPTS += -DGhcUnregisterised=1 +rts/Schedule_CC_OPTS += -DGhcUnregisterised=1 +endif + # Compile various performance-critical pieces *without* -fPIC -dynamic # even when building a shared library. If we don't do this, then the # GC runs about 50% slower on x86 due to the overheads of PIC. The diff --git a/rts/win32/AwaitEvent.c b/rts/win32/AwaitEvent.c index 1b92c4386f..af9c658e02 100644 --- a/rts/win32/AwaitEvent.c +++ b/rts/win32/AwaitEvent.c @@ -27,13 +27,11 @@ static nat workerWaitingForRequests = 0; void awaitEvent(rtsBool wait) { - int ret; - do { /* Try to de-queue completed IO requests */ workerWaitingForRequests = 1; - ret = awaitRequests(wait); + awaitRequests(wait); workerWaitingForRequests = 0; // If a signal was raised, we need to service it diff --git a/rts/win32/ThrIOManager.c b/rts/win32/ThrIOManager.c index bad621ced6..afcdc19d27 100644 --- a/rts/win32/ThrIOManager.c +++ b/rts/win32/ThrIOManager.c @@ -152,7 +152,7 @@ ioManagerStart (void) Capability *cap;
if (io_manager_event == INVALID_HANDLE_VALUE) {
cap = rts_lock();
-#if defined(mingw32_HOST_OS) && defined(__PIC__)
+#if defined(mingw32_HOST_OS) && defined(i386_HOST_Arch) && defined(__PIC__)
rts_evalIO(&cap,_imp__base_GHCziConcziIO_ensureIOManagerIsRunning_closure,NULL);
#else
rts_evalIO(&cap,&base_GHCziConcziIO_ensureIOManagerIsRunning_closure,NULL);
diff --git a/rts/win32/seh_excn.c b/rts/win32/seh_excn.c index 5da7579b10..da5f64d812 100644 --- a/rts/win32/seh_excn.c +++ b/rts/win32/seh_excn.c @@ -1,9 +1,11 @@ +#include "ghcconfig.h" #include "seh_excn.h" /* * Exception / signal handlers. */ -#if defined(__MINGW32__) +#if defined(mingw32_HOST_OS) +#if defined(i386_HOST_ARCH) jmp_buf seh_unwind_to; unsigned long seh_excn_code; /* variable used to communicate what kind of exception we've caught;nice. */ @@ -39,4 +41,5 @@ catchDivZero(struct _EXCEPTION_RECORD* rec, return ExceptionContinueSearch; } #endif +#endif diff --git a/utils/fingerprint/fingerprint.py b/utils/fingerprint/fingerprint.py index 5a753279e6..b0e599d03b 100755 --- a/utils/fingerprint/fingerprint.py +++ b/utils/fingerprint/fingerprint.py @@ -55,7 +55,7 @@ def fingerprint(source=None): `sync-all` command will be run to get the current fingerprint. """ if source is None: - sync_all = ["./sync-all", "log", "HEAD^..", "--pretty=oneline"] + sync_all = ["./sync-all", "log", "-1", "--pretty=oneline"] source = Popen(sync_all, stdout=PIPE).stdout lib = "" |