Merge remote-tracking branch 'origin/master' into ghc-parmake-gsocghc-parmake-gsoc

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