diff options
-rw-r--r-- | compiler/basicTypes/DataCon.lhs | 42 | ||||
-rw-r--r-- | compiler/basicTypes/Demand.lhs | 58 | ||||
-rw-r--r-- | compiler/basicTypes/Id.lhs | 4 | ||||
-rw-r--r-- | compiler/cmm/PprC.hs | 1 | ||||
-rw-r--r-- | compiler/deSugar/DsCCall.lhs | 41 | ||||
-rw-r--r-- | compiler/llvmGen/LlvmCodeGen/CodeGen.hs | 1 | ||||
-rw-r--r-- | compiler/main/DynFlags.hs | 25 | ||||
-rw-r--r-- | compiler/main/StaticFlags.hs | 8 | ||||
-rw-r--r-- | compiler/nativeGen/AsmCodeGen.lhs | 1 | ||||
-rw-r--r-- | compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs | 4 | ||||
-rw-r--r-- | compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs | 1 | ||||
-rw-r--r-- | compiler/nativeGen/RegAlloc/Linear/Main.hs | 1 | ||||
-rw-r--r-- | compiler/nativeGen/TargetReg.hs | 6 | ||||
-rw-r--r-- | compiler/parser/Lexer.x | 2 | ||||
-rw-r--r-- | compiler/parser/Parser.y.pp | 3 | ||||
-rw-r--r-- | compiler/parser/RdrHsSyn.lhs | 5 | ||||
-rw-r--r-- | compiler/prelude/ForeignCall.lhs | 10 | ||||
-rw-r--r-- | compiler/stranal/DmdAnal.lhs | 49 | ||||
-rw-r--r-- | compiler/typecheck/TcForeign.lhs | 5 | ||||
-rw-r--r-- | compiler/types/Type.lhs | 20 | ||||
-rw-r--r-- | compiler/utils/Platform.hs | 1 | ||||
-rw-r--r-- | rts/AutoApply.h | 2 | ||||
-rw-r--r-- | rts/PrimOps.cmm | 16 | ||||
-rw-r--r-- | utils/ghc-pkg/Main.hs | 17 |
24 files changed, 220 insertions, 103 deletions
diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index eba5c8b67d..51a096b10f 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -36,7 +36,9 @@ module DataCon ( dataConIsInfix, dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitIds, dataConRepStrictness, dataConRepBangs, dataConBoxer, - + + splitDataProductType_maybe, + -- ** Predicates on DataCons isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isUnboxedTupleCon, isVanillaDataCon, classDataCon, dataConCannotMatch, @@ -1086,3 +1088,41 @@ promoteKind (TyConApp tc []) promoteKind (FunTy arg res) = FunTy (promoteKind arg) (promoteKind res) promoteKind k = pprPanic "promoteKind" (ppr k) \end{code} + +%************************************************************************ +%* * +\subsection{Splitting products} +%* * +%************************************************************************ + +\begin{code} +-- | Extract the type constructor, type argument, data constructor and it's +-- /representation/ argument types from a type if it is a product type. +-- +-- Precisely, we return @Just@ for any type that is all of: +-- +-- * Concrete (i.e. constructors visible) +-- +-- * Single-constructor +-- +-- * Not existentially quantified +-- +-- Whether the type is a @data@ type or a @newtype@ +splitDataProductType_maybe + :: Type -- ^ A product type, perhaps + -> Maybe (TyCon, -- The type constructor + [Type], -- Type args of the tycon + DataCon, -- The data constructor + [Type]) -- Its /representation/ arg types + + -- Rejecing existentials is conservative. Maybe some things + -- could be made to work with them, but I'm not going to sweat + -- it through till someone finds it's important. + +splitDataProductType_maybe ty + | Just (tycon, ty_args) <- splitTyConApp_maybe ty + , Just con <- isDataProductTyCon_maybe tycon + = Just (tycon, ty_args, con, dataConInstArgTys con ty_args) + | otherwise + = Nothing +\end{code} diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs index 3e8096a272..ee4527e8fb 100644 --- a/compiler/basicTypes/Demand.lhs +++ b/compiler/basicTypes/Demand.lhs @@ -38,11 +38,14 @@ module Demand ( deferDmd, deferType, deferAndUse, deferEnv, modifyEnv, splitProdDmd, splitProdDmd_maybe, peelCallDmd, mkCallDmd, - dmdTransformSig, dmdTransformDataConSig, argOneShots, argsOneShots, + dmdTransformSig, dmdTransformDataConSig, dmdTransformDictSelSig, + argOneShots, argsOneShots, isSingleUsed, useType, useEnv, zapDemand, zapStrictSig, - worthSplittingFun, worthSplittingThunk + worthSplittingFun, worthSplittingThunk, + + strictifyDictDmd ) where @@ -57,6 +60,10 @@ import Util import BasicTypes import Binary import Maybes ( isJust, expectJust ) + +import Type ( Type ) +import TyCon ( isNewTyCon, isClassTyCon ) +import DataCon ( splitDataProductType_maybe ) \end{code} %************************************************************************ @@ -1303,6 +1310,21 @@ dmdTransformDataConSig arity (StrictSig (DmdType _ _ con_res)) go_abs 0 dmd = Just (splitUseProdDmd arity dmd) go_abs n (UCall One u') = go_abs (n-1) u' go_abs _ _ = Nothing + +dmdTransformDictSelSig :: StrictSig -> CleanDemand -> DmdType +-- Like dmdTransformDataConSig, we have a special demand transformer +-- for dictionary selectors. If the selector is saturated (ie has one +-- argument: the dictionary), we feed the demand on the result into +-- the indicated dictionary component. +dmdTransformDictSelSig (StrictSig (DmdType _ [dictJd] _)) cd + = case peelCallDmd cd of + (cd',False,_) -> case splitProdDmd_maybe dictJd of + Just jds -> DmdType emptyDmdEnv [mkManyUsedDmd $ mkProdDmd $ map enhance jds] topRes + where enhance old | isAbsDmd old = old + | otherwise = mkManyUsedDmd cd' + Nothing -> panic "dmdTransformDictSelSig: split failed" + _ -> topDmdType +dmdTransformDictSelSig _ _ = panic "dmdTransformDictSelSig: no args" \end{code} Note [Non-full application] @@ -1373,6 +1395,37 @@ zap_usg kfs (UProd us) = UProd (map (zap_musg kfs) us) zap_usg _ u = u \end{code} +\begin{code} +-- If the argument is a used non-newtype dictionary, give it strict +-- demand. Also split the product type & demand and recur in order to +-- similarly strictify the argument's contained used non-newtype +-- superclass dictionaries. We use the demand as our recursive measure +-- to guarantee termination. +strictifyDictDmd :: Type -> Demand -> Demand +strictifyDictDmd ty dmd = case absd dmd of + Use n _ | + Just (tycon, _arg_tys, _data_con, inst_con_arg_tys) + <- splitDataProductType_maybe ty, + not (isNewTyCon tycon), isClassTyCon tycon -- is a non-newtype dictionary + -> seqDmd `bothDmd` -- main idea: ensure it's strict + case splitProdDmd_maybe dmd of + -- superclass cycles should not be a problem, since the demand we are + -- consuming would also have to be infinite in order for us to diverge + Nothing -> dmd -- no components have interesting demand, so stop + -- looking for superclass dicts + Just dmds + | all (not . isAbsDmd) dmds -> evalDmd + -- abstract to strict w/ arbitrary component use, since this + -- smells like reboxing; results in CBV boxed + -- + -- TODO revisit this if we ever do boxity analysis + | otherwise -> case mkProdDmd $ zipWith strictifyDictDmd inst_con_arg_tys dmds of + CD {sd = s,ud = a} -> JD (Str s) (Use n a) + -- TODO could optimize with an aborting variant of zipWith since + -- the superclass dicts are always a prefix + _ -> dmd -- unused or not a dictionary +\end{code} + %************************************************************************ %* * @@ -1500,4 +1553,3 @@ instance Binary CPRResult where 2 -> return NoCPR _ -> return BotCPR \end{code} - diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs index ccd490f0fb..c2e0c2199d 100644 --- a/compiler/basicTypes/Id.lhs +++ b/compiler/basicTypes/Id.lhs @@ -479,8 +479,8 @@ zapIdStrictness :: Id -> Id zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` topSig) id -- | This predicate says whether the 'Id' has a strict demand placed on it or --- has a type such that it can always be evaluated strictly (e.g., an --- unlifted type, but see the comment for 'isStrictType'). We need to +-- has a type such that it can always be evaluated strictly (i.e an +-- unlifted type, as of GHC 7.6). We need to -- check separately whether the 'Id' has a so-called \"strict type\" because if -- the demand for the given @id@ hasn't been computed yet but @id@ has a strict -- type, we still want @isStrictId id@ to be @True@. diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index b0c9bd3f2f..149968d118 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -938,6 +938,7 @@ is_cishCC CCallConv = True is_cishCC CApiConv = True is_cishCC StdCallConv = True is_cishCC PrimCallConv = False +is_cishCC JavaScriptCallConv = False -- --------------------------------------------------------------------- -- Find and print local and external declarations for a list of diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs index c0f5019457..6df9b674a6 100644 --- a/compiler/deSugar/DsCCall.lhs +++ b/compiler/deSugar/DsCCall.lhs @@ -19,7 +19,6 @@ module DsCCall , unboxArg , boxResult , resultWrapper - , splitDataProductType_maybe ) where #include "HsVersions.h" @@ -392,43 +391,3 @@ maybeNarrow dflags tycon && wORD_SIZE dflags > 4 = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e | otherwise = id \end{code} - -%************************************************************************ -%* * -\subsection{Splitting products} -%* * -%************************************************************************ - -\begin{code} --- | Extract the type constructor, type argument, data constructor and it's --- /representation/ argument types from a type if it is a product type. --- --- Precisely, we return @Just@ for any type that is all of: --- --- * Concrete (i.e. constructors visible) --- --- * Single-constructor --- --- * Not existentially quantified --- --- Whether the type is a @data@ type or a @newtype@ -splitDataProductType_maybe - :: Type -- ^ A product type, perhaps - -> Maybe (TyCon, -- The type constructor - [Type], -- Type args of the tycon - DataCon, -- The data constructor - [Type]) -- Its /representation/ arg types - - -- Rejecing existentials is conservative. Maybe some things - -- could be made to work with them, but I'm not going to sweat - -- it through till someone finds it's important. - -splitDataProductType_maybe ty - | Just (tycon, ty_args) <- splitTyConApp_maybe ty - , Just con <- isDataProductTyCon_maybe tycon - = Just (tycon, ty_args, con, dataConInstArgTys con ty_args) - | otherwise - = Nothing -\end{code} - - diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index 6f898fa56c..def9e2b81e 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -296,6 +296,7 @@ genCall target res args = do CCallConv -> CC_Ccc CApiConv -> CC_Ccc PrimCallConv -> panic "LlvmCodeGen.CodeGen.genCall: PrimCallConv" + JavaScriptCallConv -> panic "LlvmCodeGen.CodeGen.genCall: JavaScriptCallConv" PrimTarget _ -> CC_Ccc diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 25553d280b..2c82f448b8 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -308,6 +308,8 @@ data GeneralFlag | Opt_OmitYields | Opt_SimpleListLiterals | Opt_FunToThunk -- allow WwLib.mkWorkerArgs to remove all value lambdas + | Opt_DictsStrict -- be strict in argument dictionaries + | Opt_DmdTxDictSel -- use a special demand transformer for dictionary selectors -- Interface files | Opt_IgnoreInterfacePragmas @@ -489,6 +491,7 @@ data ExtensionFlag | Opt_InterruptibleFFI | Opt_CApiFFI | Opt_GHCForeignImportPrim + | Opt_JavaScriptFFI | Opt_ParallelArrays -- Syntactic support for parallel arrays | Opt_Arrows -- Arrow-notation syntax | Opt_TemplateHaskell @@ -1026,7 +1029,8 @@ data RtsOptsEnabled = RtsOptsNone | RtsOptsSafeOnly | RtsOptsAll -- this compilation. data Way - = WayThreaded + = WayCustom String -- for GHC API clients building custom variants + | WayThreaded | WayDebug | WayProf | WayEventLog @@ -1052,6 +1056,7 @@ allowed_combination way = and [ x `allowedWith` y _ `allowedWith` WayDebug = True WayDebug `allowedWith` _ = True + (WayCustom {}) `allowedWith` _ = True WayProf `allowedWith` WayNDP = True WayThreaded `allowedWith` WayProf = True WayThreaded `allowedWith` WayEventLog = True @@ -1061,6 +1066,7 @@ mkBuildTag :: [Way] -> String mkBuildTag ways = concat (intersperse "_" (map wayTag ways)) wayTag :: Way -> String +wayTag (WayCustom xs) = xs wayTag WayThreaded = "thr" wayTag WayDebug = "debug" wayTag WayDyn = "dyn" @@ -1071,6 +1077,7 @@ wayTag WayGran = "mg" wayTag WayNDP = "ndp" wayRTSOnly :: Way -> Bool +wayRTSOnly (WayCustom {}) = False wayRTSOnly WayThreaded = True wayRTSOnly WayDebug = True wayRTSOnly WayDyn = False @@ -1081,6 +1088,7 @@ wayRTSOnly WayGran = False wayRTSOnly WayNDP = False wayDesc :: Way -> String +wayDesc (WayCustom xs) = xs wayDesc WayThreaded = "Threaded" wayDesc WayDebug = "Debug" wayDesc WayDyn = "Dynamic" @@ -1092,6 +1100,7 @@ wayDesc WayNDP = "Nested data parallelism" -- Turn these flags on when enabling this way wayGeneralFlags :: Platform -> Way -> [GeneralFlag] +wayGeneralFlags _ (WayCustom {}) = [] wayGeneralFlags _ WayThreaded = [] wayGeneralFlags _ WayDebug = [] wayGeneralFlags _ WayDyn = [Opt_PIC] @@ -1103,6 +1112,7 @@ wayGeneralFlags _ WayNDP = [] -- Turn these flags off when enabling this way wayUnsetGeneralFlags :: Platform -> Way -> [GeneralFlag] +wayUnsetGeneralFlags _ (WayCustom {}) = [] wayUnsetGeneralFlags _ WayThreaded = [] wayUnsetGeneralFlags _ WayDebug = [] wayUnsetGeneralFlags _ WayDyn = [-- There's no point splitting objects @@ -1117,6 +1127,7 @@ wayUnsetGeneralFlags _ WayGran = [] wayUnsetGeneralFlags _ WayNDP = [] wayExtras :: Platform -> Way -> DynFlags -> DynFlags +wayExtras _ (WayCustom {}) dflags = dflags wayExtras _ WayThreaded dflags = dflags wayExtras _ WayDebug dflags = dflags wayExtras _ WayDyn dflags = dflags @@ -1128,6 +1139,7 @@ wayExtras _ WayNDP dflags = setExtensionFlag' Opt_ParallelArrays $ setGeneralFlag' Opt_Vectorise dflags wayOptc :: Platform -> Way -> [String] +wayOptc _ (WayCustom {}) = [] wayOptc platform WayThreaded = case platformOS platform of OSOpenBSD -> ["-pthread"] OSNetBSD -> ["-pthread"] @@ -1141,6 +1153,7 @@ wayOptc _ WayGran = ["-DGRAN"] wayOptc _ WayNDP = [] wayOptl :: Platform -> Way -> [String] +wayOptl _ (WayCustom {}) = [] wayOptl platform WayThreaded = case platformOS platform of -- FreeBSD's default threading library is the KSE-based M:N libpthread, @@ -1163,6 +1176,7 @@ wayOptl _ WayGran = [] wayOptl _ WayNDP = [] wayOptP :: Platform -> Way -> [String] +wayOptP _ (WayCustom {}) = [] wayOptP _ WayThreaded = [] wayOptP _ WayDebug = [] wayOptP _ WayDyn = [] @@ -2590,7 +2604,9 @@ fFlags = [ ( "flat-cache", Opt_FlatCache, nop ), ( "use-rpaths", Opt_RPath, nop ), ( "kill-absence", Opt_KillAbsence, nop), - ( "kill-one-shot", Opt_KillOneShot, nop) + ( "kill-one-shot", Opt_KillOneShot, nop), + ( "dicts-strict", Opt_DictsStrict, nop ), + ( "dmd-tx-dict-sel", Opt_DmdTxDictSel, nop ) ] -- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@ @@ -2679,6 +2695,7 @@ xFlags = [ ( "InterruptibleFFI", Opt_InterruptibleFFI, nop ), ( "CApiFFI", Opt_CApiFFI, nop ), ( "GHCForeignImportPrim", Opt_GHCForeignImportPrim, nop ), + ( "JavaScriptFFI", Opt_JavaScriptFFI, nop ), ( "LiberalTypeSynonyms", Opt_LiberalTypeSynonyms, nop ), ( "PolymorphicComponents", Opt_RankNTypes, nop), @@ -2844,6 +2861,8 @@ impliedFlags -- `IP "x" Int`, which requires a flexible context/instance. , (Opt_ImplicitParams, turnOn, Opt_FlexibleContexts) , (Opt_ImplicitParams, turnOn, Opt_FlexibleInstances) + + , (Opt_JavaScriptFFI, turnOn, Opt_InterruptibleFFI) ] optLevelFlags :: [([Int], GeneralFlag)] @@ -2871,6 +2890,8 @@ optLevelFlags , ([1,2], Opt_CmmSink) , ([1,2], Opt_CmmElimCommonBlocks) + , ([0,1,2], Opt_DmdTxDictSel) + -- , ([2], Opt_StaticArgumentTransformation) -- Max writes: I think it's probably best not to enable SAT with -O2 for the -- 6.10 release. The version of SAT in HEAD at the moment doesn't incorporate diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index 09d5772637..1eb01ca599 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -23,9 +23,6 @@ module StaticFlags ( opt_PprStyle_Debug, opt_NoDebugOutput, - -- language opts - opt_DictsStrict, - -- optimisation opts opt_NoStateHack, opt_CprOff, @@ -149,7 +146,6 @@ isStaticFlag f = f `elem` flagsStaticNames flagsStaticNames :: [String] flagsStaticNames = [ - "fdicts-strict", "fno-state-hack", "fno-opt-coercion", "fcpr-off" @@ -189,10 +185,6 @@ opt_PprStyle_Debug = lookUp (fsLit "-dppr-debug") opt_NoDebugOutput :: Bool opt_NoDebugOutput = lookUp (fsLit "-dno-debug-output") --- language opts -opt_DictsStrict :: Bool -opt_DictsStrict = lookUp (fsLit "-fdicts-strict") - opt_NoStateHack :: Bool opt_NoStateHack = lookUp (fsLit "-fno-state-hack") diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index a999f8f45a..42eeb4ff13 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -170,6 +170,7 @@ nativeCodeGen dflags this_mod h us cmms ArchMipseb -> panic "nativeCodeGen: No NCG for mipseb" ArchMipsel -> panic "nativeCodeGen: No NCG for mipsel" ArchUnknown -> panic "nativeCodeGen: No NCG for unknown arch" + ArchJavaScript -> panic "nativeCodeGen: No NCG for JavaScript" x86NcgImpl :: DynFlags -> NcgImpl (Alignment, CmmStatics) X86.Instr.Instr X86.Instr.JumpDest x86NcgImpl dflags diff --git a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs index 378e1755e6..df3c7d6d41 100644 --- a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs +++ b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs @@ -116,6 +116,7 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcInteger conflicts excl ArchAlpha -> panic "trivColorable ArchAlpha" ArchMipseb -> panic "trivColorable ArchMipseb" ArchMipsel -> panic "trivColorable ArchMipsel" + ArchJavaScript-> panic "trivColorable ArchJavaScript" ArchUnknown -> panic "trivColorable ArchUnknown") , count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_INTEGER (virtualRegSqueeze RcInteger) @@ -139,6 +140,7 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcFloat conflicts exclus ArchAlpha -> panic "trivColorable ArchAlpha" ArchMipseb -> panic "trivColorable ArchMipseb" ArchMipsel -> panic "trivColorable ArchMipsel" + ArchJavaScript-> panic "trivColorable ArchJavaScript" ArchUnknown -> panic "trivColorable ArchUnknown") , count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_FLOAT (virtualRegSqueeze RcFloat) @@ -162,6 +164,7 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcDouble conflicts exclu ArchAlpha -> panic "trivColorable ArchAlpha" ArchMipseb -> panic "trivColorable ArchMipseb" ArchMipsel -> panic "trivColorable ArchMipsel" + ArchJavaScript-> panic "trivColorable ArchJavaScript" ArchUnknown -> panic "trivColorable ArchUnknown") , count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_DOUBLE (virtualRegSqueeze RcDouble) @@ -185,6 +188,7 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcDoubleSSE conflicts ex ArchAlpha -> panic "trivColorable ArchAlpha" ArchMipseb -> panic "trivColorable ArchMipseb" ArchMipsel -> panic "trivColorable ArchMipsel" + ArchJavaScript-> panic "trivColorable ArchJavaScript" ArchUnknown -> panic "trivColorable ArchUnknown") , count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_SSE (virtualRegSqueeze RcDoubleSSE) diff --git a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs index 220904ec01..557d713fe3 100644 --- a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs +++ b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs @@ -78,5 +78,6 @@ maxSpillSlots dflags ArchAlpha -> panic "maxSpillSlots ArchAlpha" ArchMipseb -> panic "maxSpillSlots ArchMipseb" ArchMipsel -> panic "maxSpillSlots ArchMipsel" + ArchJavaScript-> panic "maxSpillSlots ArchJavaScript" ArchUnknown -> panic "maxSpillSlots ArchUnknown" diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index 6348b41690..6ac19dad40 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -211,6 +211,7 @@ linearRegAlloc dflags first_id block_live sccs ArchAlpha -> panic "linearRegAlloc ArchAlpha" ArchMipseb -> panic "linearRegAlloc ArchMipseb" ArchMipsel -> panic "linearRegAlloc ArchMipsel" + ArchJavaScript -> panic "linearRegAlloc ArchJavaScript" ArchUnknown -> panic "linearRegAlloc ArchUnknown" linearRegAlloc' diff --git a/compiler/nativeGen/TargetReg.hs b/compiler/nativeGen/TargetReg.hs index f380534c88..378db10efe 100644 --- a/compiler/nativeGen/TargetReg.hs +++ b/compiler/nativeGen/TargetReg.hs @@ -57,8 +57,10 @@ targetVirtualRegSqueeze platform ArchAlpha -> panic "targetVirtualRegSqueeze ArchAlpha" ArchMipseb -> panic "targetVirtualRegSqueeze ArchMipseb" ArchMipsel -> panic "targetVirtualRegSqueeze ArchMipsel" + ArchJavaScript-> panic "targetVirtualRegSqueeze ArchJavaScript" ArchUnknown -> panic "targetVirtualRegSqueeze ArchUnknown" + targetRealRegSqueeze :: Platform -> RegClass -> RealReg -> FastInt targetRealRegSqueeze platform = case platformArch platform of @@ -71,6 +73,7 @@ targetRealRegSqueeze platform ArchAlpha -> panic "targetRealRegSqueeze ArchAlpha" ArchMipseb -> panic "targetRealRegSqueeze ArchMipseb" ArchMipsel -> panic "targetRealRegSqueeze ArchMipsel" + ArchJavaScript-> panic "targetRealRegSqueeze ArchJavaScript" ArchUnknown -> panic "targetRealRegSqueeze ArchUnknown" targetClassOfRealReg :: Platform -> RealReg -> RegClass @@ -85,6 +88,7 @@ targetClassOfRealReg platform ArchAlpha -> panic "targetClassOfRealReg ArchAlpha" ArchMipseb -> panic "targetClassOfRealReg ArchMipseb" ArchMipsel -> panic "targetClassOfRealReg ArchMipsel" + ArchJavaScript-> panic "targetClassOfRealReg ArchJavaScript" ArchUnknown -> panic "targetClassOfRealReg ArchUnknown" targetMkVirtualReg :: Platform -> Unique -> Size -> VirtualReg @@ -99,6 +103,7 @@ targetMkVirtualReg platform ArchAlpha -> panic "targetMkVirtualReg ArchAlpha" ArchMipseb -> panic "targetMkVirtualReg ArchMipseb" ArchMipsel -> panic "targetMkVirtualReg ArchMipsel" + ArchJavaScript-> panic "targetMkVirtualReg ArchJavaScript" ArchUnknown -> panic "targetMkVirtualReg ArchUnknown" targetRegDotColor :: Platform -> RealReg -> SDoc @@ -113,6 +118,7 @@ targetRegDotColor platform ArchAlpha -> panic "targetRegDotColor ArchAlpha" ArchMipseb -> panic "targetRegDotColor ArchMipseb" ArchMipsel -> panic "targetRegDotColor ArchMipsel" + ArchJavaScript-> panic "targetRegDotColor ArchJavaScript" ArchUnknown -> panic "targetRegDotColor ArchUnknown" diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 95880946bb..12389e7f17 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -472,6 +472,7 @@ data Token | ITccallconv | ITcapiconv | ITprimcallconv + | ITjavascriptcallconv | ITmdo | ITfamily | ITgroup @@ -668,6 +669,7 @@ reservedWordsFM = listToUFM $ ( "ccall", ITccallconv, bit ffiBit), ( "capi", ITcapiconv, bit cApiFfiBit), ( "prim", ITprimcallconv, bit ffiBit), + ( "javascript", ITjavascriptcallconv, bit ffiBit), ( "rec", ITrec, bit arrowsBit .|. bit recursiveDoBit), diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 634d3c76f0..b18d0d35c6 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -251,6 +251,7 @@ incorrect. 'ccall' { L _ ITccallconv } 'capi' { L _ ITcapiconv } 'prim' { L _ ITprimcallconv } + 'javascript' { L _ ITjavascriptcallconv } 'proc' { L _ ITproc } -- for arrow notation extension 'rec' { L _ ITrec } -- for arrow notation extension 'group' { L _ ITgroup } -- for list transform extension @@ -977,6 +978,7 @@ callconv :: { CCallConv } | 'ccall' { CCallConv } | 'capi' { CApiConv } | 'prim' { PrimCallConv} + | 'javascript' { JavaScriptCallConv } safety :: { Safety } : 'unsafe' { PlayRisky } @@ -2047,6 +2049,7 @@ special_id | 'ccall' { L1 (fsLit "ccall") } | 'capi' { L1 (fsLit "capi") } | 'prim' { L1 (fsLit "prim") } + | 'javascript' { L1 (fsLit "javascript") } | 'group' { L1 (fsLit "group") } special_sym :: { Located FastString } diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index ea4c65357d..fb5f43f5e9 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -972,7 +972,10 @@ mkImport cconv safety (L loc entity, v, ty) let funcTarget = CFunction (StaticTarget entity Nothing True) importSpec = CImport PrimCallConv safety Nothing funcTarget return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec)) - + | cconv == JavaScriptCallConv = do + let funcTarget = CFunction (StaticTarget entity Nothing True) + importSpec = CImport JavaScriptCallConv safety Nothing funcTarget + return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec)) | otherwise = do case parseCImport cconv safety (mkExtName (unLoc v)) (unpackFS entity) of Nothing -> parseErrorSDoc loc (text "Malformed entity string") diff --git a/compiler/prelude/ForeignCall.lhs b/compiler/prelude/ForeignCall.lhs index b53ae7cf50..5072908e6a 100644 --- a/compiler/prelude/ForeignCall.lhs +++ b/compiler/prelude/ForeignCall.lhs @@ -156,7 +156,7 @@ platforms. See: http://www.programmersheaven.com/2/Calling-conventions \begin{code} -data CCallConv = CCallConv | CApiConv | StdCallConv | PrimCallConv +data CCallConv = CCallConv | CApiConv | StdCallConv | PrimCallConv | JavaScriptCallConv deriving (Eq, Data, Typeable) {-! derive: Binary !-} @@ -165,6 +165,7 @@ instance Outputable CCallConv where ppr CCallConv = ptext (sLit "ccall") ppr CApiConv = ptext (sLit "capi") ppr PrimCallConv = ptext (sLit "prim") + ppr JavaScriptCallConv = ptext (sLit "javascript") defaultCCallConv :: CCallConv defaultCCallConv = CCallConv @@ -174,6 +175,7 @@ ccallConvToInt StdCallConv = 0 ccallConvToInt CCallConv = 1 ccallConvToInt CApiConv = panic "ccallConvToInt CApiConv" ccallConvToInt (PrimCallConv {}) = panic "ccallConvToInt PrimCallConv" +ccallConvToInt JavaScriptCallConv = panic "ccallConvToInt JavaScriptCallConv" \end{code} Generate the gcc attribute corresponding to the given @@ -185,6 +187,7 @@ ccallConvAttribute StdCallConv = text "__attribute__((__stdcall__))" ccallConvAttribute CCallConv = empty ccallConvAttribute CApiConv = empty ccallConvAttribute (PrimCallConv {}) = panic "ccallConvAttribute PrimCallConv" +ccallConvAttribute JavaScriptCallConv = panic "ccallConvAttribute JavaScriptCallConv" \end{code} \begin{code} @@ -324,13 +327,16 @@ instance Binary CCallConv where putByte bh 2 put_ bh CApiConv = do putByte bh 3 + put_ bh JavaScriptCallConv = do + putByte bh 4 get bh = do h <- getByte bh case h of 0 -> do return CCallConv 1 -> do return StdCallConv 2 -> do return PrimCallConv - _ -> do return CApiConv + 3 -> do return CApiConv + _ -> do return JavaScriptCallConv instance Binary CType where put_ bh (CType mh fs) = do put_ bh mh diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs index 0aff8ffd93..98c4083ddf 100644 --- a/compiler/stranal/DmdAnal.lhs +++ b/compiler/stranal/DmdAnal.lhs @@ -180,6 +180,7 @@ dmdAnal env dmd (App fun arg) -- Non-type arguments -- , text "overall res dmd_ty =" <+> ppr (res_ty `bothDmdType` arg_ty) ]) (res_ty `bothDmdType` arg_ty, App fun' arg') +-- this is an anonymous lambda, since @dmdAnalRhs@ uses @collectBinders@ dmdAnal env dmd (Lam var body) | isTyVar var = let @@ -195,7 +196,7 @@ dmdAnal env dmd (Lam var body) env' = extendSigsWithLam env var (body_ty, body') = dmdAnal env' body_dmd body - (lam_ty, var') = annotateLamIdBndr env body_ty one_shot var + (lam_ty, var') = annotateLamIdBndr env notArgOfDfun body_ty one_shot var in (deferAndUse defer_me one_shot lam_ty, Lam var' body') @@ -480,6 +481,10 @@ dmdTransform env var dmd = dmdTransformDataConSig (idArity var) (idStrictness var) dmd + | gopt Opt_DmdTxDictSel (ae_dflags env), + Just _ <- isClassOpId_maybe var -- Dictionary component selector + = dmdTransformDictSelSig (idStrictness var) dmd + | isGlobalId var -- Imported function = let res = dmdTransformSig (idStrictness var) dmd in -- pprTrace "dmdTransform" (vcat [ppr var, ppr (idStrictness var), ppr dmd, ppr res]) @@ -589,7 +594,7 @@ dmdAnalRhs top_lvl rec_flag env id rhs (bndrs, body) = collectBinders rhs env_body = foldl extendSigsWithLam env bndrs (body_dmd_ty, body') = dmdAnal env_body body_dmd body - (rhs_dmd_ty, bndrs') = annotateLamBndrs env body_dmd_ty bndrs + (rhs_dmd_ty, bndrs') = annotateLamBndrs env (isDFunId id) body_dmd_ty bndrs id' = set_idStrictness env id sig_ty sig_ty = mkStrictSig (mkDmdType sig_fv rhs_dmds rhs_res') -- See Note [NOINLINE and strictness] @@ -733,6 +738,13 @@ the safe result we also have absent demand set to Abs, which makes it possible to safely ignore non-mentioned variables (their joint demand is <L,A>). +Note [do not strictify the argument dictionaries of a dfun] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The typechecker can tie recursive knots involving dfuns, so we do the +conservative thing and refrain from strictifying a dfun's argument +dictionaries. + \begin{code} annotateBndr :: AnalEnv -> DmdType -> Var -> (DmdType, Var) -- The returned env has the var deleted @@ -741,33 +753,41 @@ annotateBndr :: AnalEnv -> DmdType -> Var -> (DmdType, Var) -- No effect on the argument demands annotateBndr env dmd_ty@(DmdType fv ds res) var | isTyVar var = (dmd_ty, var) - | otherwise = (DmdType fv' ds res, set_idDemandInfo env var dmd) + | otherwise = (DmdType fv' ds res, set_idDemandInfo env var dmd') where (fv', dmd) = peelFV fv var res + dmd' | gopt Opt_DictsStrict (ae_dflags env) + -- We never want to strictify a recursive let. At the moment + -- annotateBndr is only call for non-recursive lets; if that + -- changes, we need a RecFlag parameter and another guard here. + = strictifyDictDmd (idType var) dmd + | otherwise = dmd + annotateBndrs :: AnalEnv -> DmdType -> [Var] -> (DmdType, [Var]) annotateBndrs env = mapAccumR (annotateBndr env) -annotateLamBndrs :: AnalEnv -> DmdType -> [Var] -> (DmdType, [Var]) -annotateLamBndrs env ty bndrs = mapAccumR annotate ty bndrs +annotateLamBndrs :: AnalEnv -> DFunFlag -> DmdType -> [Var] -> (DmdType, [Var]) +annotateLamBndrs env args_of_dfun ty bndrs = mapAccumR annotate ty bndrs where annotate dmd_ty bndr - | isId bndr = annotateLamIdBndr env dmd_ty Many bndr + | isId bndr = annotateLamIdBndr env args_of_dfun dmd_ty Many bndr | otherwise = (dmd_ty, bndr) annotateLamIdBndr :: AnalEnv + -> DFunFlag -- is this lambda at the top of the RHS of a dfun? -> DmdType -- Demand type of body -> Count -- One-shot-ness of the lambda -> Id -- Lambda binder -> (DmdType, -- Demand type of lambda Id) -- and binder annotated with demand -annotateLamIdBndr env _dmd_ty@(DmdType fv ds res) one_shot id +annotateLamIdBndr env arg_of_dfun _dmd_ty@(DmdType fv ds res) one_shot id -- For lambdas we add the demand to the argument demands -- Only called for Ids = ASSERT( isId id ) -- pprTrace "annLamBndr" (vcat [ppr id, ppr _dmd_ty]) $ - (final_ty, setOneShotness one_shot (set_idDemandInfo env id dmd)) + (final_ty, setOneShotness one_shot (set_idDemandInfo env id dmd')) where -- Watch out! See note [Lambda-bound unfoldings] final_ty = case maybeUnfoldingTemplate (idUnfolding id) of @@ -780,6 +800,12 @@ annotateLamIdBndr env _dmd_ty@(DmdType fv ds res) one_shot id (fv', dmd) = peelFV fv id res + dmd' | gopt Opt_DictsStrict (ae_dflags env), + -- see Note [do not strictify the argument dictionaries of a dfun] + not arg_of_dfun + = strictifyDictDmd (idType id) dmd + | otherwise = dmd + deleteFVs :: DmdType -> [Var] -> DmdType deleteFVs (DmdType fvs dmds res) bndrs = DmdType (delVarEnvList fvs bndrs) dmds res @@ -985,13 +1011,18 @@ forget that fact, otherwise we might make 'x' absent when it isn't. %************************************************************************ \begin{code} +type DFunFlag = Bool -- indicates if the lambda being considered is in the + -- sequence of lambdas at the top of the RHS of a dfun +notArgOfDfun :: DFunFlag +notArgOfDfun = False + data AnalEnv = AE { ae_dflags :: DynFlags , ae_sigs :: SigEnv , ae_virgin :: Bool -- True on first iteration only -- See Note [Initialising strictness] , ae_rec_tc :: RecTcChecker - } + } -- We use the se_env to tell us whether to -- record info about a variable in the DmdEnv diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index 9914f94c5f..d755132696 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -481,6 +481,11 @@ checkCConv StdCallConv = do dflags <- getDynFlags return CCallConv checkCConv PrimCallConv = do addErrTc (text "The `prim' calling convention can only be used with `foreign import'") return PrimCallConv +checkCConv JavaScriptCallConv = do dflags <- getDynFlags + if platformArch (targetPlatform dflags) == ArchJavaScript + then return JavaScriptCallConv + else do addErrTc (text "The `javascript' calling convention is unsupported on this platform") + return JavaScriptCallConv \end{code} Warnings diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index 5753aba0c1..9db0aaa3ee 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -166,7 +166,6 @@ import CoAxiom -- others import Unique ( Unique, hasKey ) import BasicTypes ( Arity, RepArity ) -import StaticFlags import Util import Outputable import FastString @@ -1093,25 +1092,10 @@ isClosedAlgType ty \begin{code} -- | Computes whether an argument (or let right hand side) should -- be computed strictly or lazily, based only on its type. --- Works just like 'isUnLiftedType', except that it has a special case --- for dictionaries (i.e. does not work purely on representation types) +-- Currently, it's just 'isUnLiftedType'. --- Since it takes account of class 'PredType's, you might think --- this function should be in 'TcType', but 'isStrictType' is used by 'DataCon', --- which is below 'TcType' in the hierarchy, so it's convenient to put it here. --- --- We may be strict in dictionary types, but only if it --- has more than one component. --- --- (Being strict in a single-component dictionary risks --- poking the dictionary component, which is wrong.) isStrictType :: Type -> Bool -isStrictType ty | Just ty' <- coreView ty = isStrictType ty' -isStrictType (ForAllTy _ ty) = isStrictType ty -isStrictType (TyConApp tc _) - | isUnLiftedTyCon tc = True - | isClassTyCon tc, opt_DictsStrict = True -isStrictType _ = False +isStrictType = isUnLiftedType \end{code} \begin{code} diff --git a/compiler/utils/Platform.hs b/compiler/utils/Platform.hs index 617e691ddf..f69bb4cdf6 100644 --- a/compiler/utils/Platform.hs +++ b/compiler/utils/Platform.hs @@ -54,6 +54,7 @@ data Arch | ArchAlpha | ArchMipseb | ArchMipsel + | ArchJavaScript deriving (Read, Show, Eq) isARM :: Arch -> Bool diff --git a/rts/AutoApply.h b/rts/AutoApply.h index c48bdf4701..f64bc6d894 100644 --- a/rts/AutoApply.h +++ b/rts/AutoApply.h @@ -20,6 +20,7 @@ size = SIZEOF_StgPAP + WDS(n); \ HP_CHK_NP_ASSIGN_SP0(size,f); \ TICK_ALLOC_PAP(size, 0); \ + CCCS_ALLOC(size); \ pap = Hp + WDS(1) - size; \ SET_HDR(pap, stg_PAP_info, CCCS); \ StgPAP_arity(pap) = HALF_W_(arity - m); \ @@ -49,6 +50,7 @@ size = SIZEOF_StgPAP + WDS(TO_W_(StgPAP_n_args(pap))) + WDS(n); \ HP_CHK_NP_ASSIGN_SP0(size,f); \ TICK_ALLOC_PAP(size, 0); \ + CCCS_ALLOC(size); \ new_pap = Hp + WDS(1) - size; \ SET_HDR(new_pap, stg_PAP_info, CCCS); \ StgPAP_arity(new_pap) = HALF_W_(arity - m); \ diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm index 3cfec94b72..e278bb70ab 100644 --- a/rts/PrimOps.cmm +++ b/rts/PrimOps.cmm @@ -460,14 +460,6 @@ stg_addCFinalizzerToWeakzh ( W_ fptr, // finalizer { W_ c, info; - LOCK_CLOSURE(w, info); - - if (info == stg_DEAD_WEAK_info) { - // Already dead. - unlockClosure(w, info); - return (0); - } - ALLOC_PRIM (SIZEOF_StgCFinalizerList) c = Hp - SIZEOF_StgCFinalizerList + WDS(1); @@ -478,6 +470,14 @@ stg_addCFinalizzerToWeakzh ( W_ fptr, // finalizer StgCFinalizerList_eptr(c) = eptr; StgCFinalizerList_flag(c) = flag; + LOCK_CLOSURE(w, info); + + if (info == stg_DEAD_WEAK_info) { + // Already dead. + unlockClosure(w, info); + return (0); + } + StgCFinalizerList_link(c) = StgWeak_cfinalizers(w); StgWeak_cfinalizers(w) = c; diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index e2f497f36c..41ed265f4b 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -33,6 +33,7 @@ import qualified Control.Exception as Exception import Data.Maybe import Data.Char ( isSpace, toLower ) +import Data.Ord (comparing) import Control.Monad import System.Directory ( doesDirectoryExist, getDirectoryContents, doesFileExist, renameFile, removeFile, @@ -1012,7 +1013,8 @@ listPackages verbosity my_flags mPackageName mModuleName = do then hPutStrLn stdout " (no packages)" else hPutStrLn stdout $ unlines (map (" " ++) pp_pkgs) where - pp_pkgs = map pp_pkg pkg_confs + -- Sort using instance Ord PackageId + pp_pkgs = map pp_pkg . sortBy (comparing installedPackageId) $ pkg_confs pp_pkg p | sourcePackageId p `elem` broken = printf "{%s}" doc | exposed p = doc @@ -1066,7 +1068,8 @@ simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO () simplePackageList my_flags pkgs = do let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName else display - strs = map showPkg $ sortBy compPkgIdVer $ map sourcePackageId pkgs + -- Sort using instance Ord PackageId + strs = map showPkg $ sort $ map sourcePackageId pkgs when (not (null pkgs)) $ hPutStrLn stdout $ concat $ intersperse " " strs @@ -1098,10 +1101,11 @@ latestPackage verbosity my_flags pkgid = do getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags ps <- findPackages flag_db_stack (Id pkgid) - show_pkg (sortBy compPkgIdVer (map sourcePackageId ps)) + case ps of + [] -> die "no matches" + _ -> show_pkg . maximum . map sourcePackageId $ ps where - show_pkg [] = die "no matches" - show_pkg pids = hPutStrLn stdout (display (last pids)) + show_pkg pid = hPutStrLn stdout (display pid) -- ----------------------------------------------------------------------------- -- Describe @@ -1165,9 +1169,6 @@ matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool (Id pid) `matchesPkg` pkg = pid `matches` sourcePackageId pkg (Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg)) -compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering -compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2 - -- ----------------------------------------------------------------------------- -- Field |