Commit 783ca393 authored by parcs's avatar parcs

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

parents a58ba185 2cec084e
......@@ -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}
......@@ -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}
......@@ -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@.
......
......@@ -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
......
......@@ -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}
......@@ -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
......
......@@ -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
......
......@@ -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")
......
......@@ -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
......
......@@ -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)
......
......@@ -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"
......@@ -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'
......
......@@ -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"
......
......@@ -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),
......
......@@ -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 }
......
......@@ -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")
......
......@@ -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
......
......@@ -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)