summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/cmm/PprC.hs1
-rw-r--r--compiler/llvmGen/LlvmCodeGen/CodeGen.hs1
-rw-r--r--compiler/main/DynFlags.hs17
-rw-r--r--compiler/nativeGen/AsmCodeGen.lhs1
-rw-r--r--compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs4
-rw-r--r--compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs1
-rw-r--r--compiler/nativeGen/RegAlloc/Linear/Main.hs1
-rw-r--r--compiler/nativeGen/TargetReg.hs6
-rw-r--r--compiler/parser/Lexer.x2
-rw-r--r--compiler/parser/Parser.y.pp3
-rw-r--r--compiler/parser/RdrHsSyn.lhs5
-rw-r--r--compiler/prelude/ForeignCall.lhs10
-rw-r--r--compiler/typecheck/TcForeign.lhs5
-rw-r--r--compiler/utils/Platform.hs1
14 files changed, 54 insertions, 4 deletions
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/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 e80cf656d3..6e895d3a34 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -489,6 +489,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
@@ -1021,7 +1022,8 @@ data RtsOptsEnabled = RtsOptsNone | RtsOptsSafeOnly | RtsOptsAll
-- this compilation.
data Way
- = WayThreaded
+ = WayCustom String -- for GHC API clients building custom variants
+ | WayThreaded
| WayDebug
| WayProf
| WayEventLog
@@ -1047,6 +1049,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
@@ -1056,6 +1059,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"
@@ -1066,6 +1070,7 @@ wayTag WayGran = "mg"
wayTag WayNDP = "ndp"
wayRTSOnly :: Way -> Bool
+wayRTSOnly (WayCustom {}) = False
wayRTSOnly WayThreaded = True
wayRTSOnly WayDebug = True
wayRTSOnly WayDyn = False
@@ -1076,6 +1081,7 @@ wayRTSOnly WayGran = False
wayRTSOnly WayNDP = False
wayDesc :: Way -> String
+wayDesc (WayCustom xs) = xs
wayDesc WayThreaded = "Threaded"
wayDesc WayDebug = "Debug"
wayDesc WayDyn = "Dynamic"
@@ -1087,6 +1093,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]
@@ -1098,6 +1105,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
@@ -1112,6 +1120,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
@@ -1123,6 +1132,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"]
@@ -1136,6 +1146,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,
@@ -1158,6 +1169,7 @@ wayOptl _ WayGran = []
wayOptl _ WayNDP = []
wayOptP :: Platform -> Way -> [String]
+wayOptP _ (WayCustom {}) = []
wayOptP _ WayThreaded = []
wayOptP _ WayDebug = []
wayOptP _ WayDyn = []
@@ -2667,6 +2679,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),
@@ -2832,6 +2845,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)]
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/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/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
View Lorry Controller Status