Commit b372e8ea authored by thoughtpolice's avatar thoughtpolice

Add basic support for GHCJS

This patch encompasses most of the basic infrastructure for GHCJS. It
includes:

  * A new extension, -XJavaScriptFFI
  * A new architecture, ArchJavaScript
  * Parser and lexer support for 'foreign import javascript', only
    available under -XJavaScriptFFI, using ArchJavaScript.
  * As a knock-on, there is also a new 'WayCustom' constructor in
    DynFlags, so clients of the GHC API can add custom 'tags' to their
    built files. This should be useful for other users as well.

The remaining changes are really just the resulting fallout, making sure
all the cases are handled appropriately for DynFlags and Platform.
Authored-by: Luite Stegeman's avatarLuite Stegeman <stegeman@gmail.com>
Signed-off-by: thoughtpolice's avatarAustin Seipp <aseipp@pobox.com>
parent df614779
......@@ -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
......
......@@ -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
......
......@@ -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)]
......
......@@ -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
......
......@@ -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
......
......@@ -54,6 +54,7 @@ data Arch
| ArchAlpha
| ArchMipseb
| ArchMipsel
| ArchJavaScript
deriving (Read, Show, Eq)
isARM :: Arch -> Bool
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment