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

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}

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}
-

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@.

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

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}
-
-

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
 

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

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")
 

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

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)

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"
 

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'

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"
 
 

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),

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 }

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")

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

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)