-% (c) The University of Glasgow 2001
+% (c) The University of Glasgow 2001-2006
%
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
module MkExternalCore (
emitExternalCore
#include "HsVersions.h"
import qualified ExternalCore as C
-import Char
import Module
import CoreSyn
import HscTypes
import TyCon
import TypeRep
import Type
-import PprExternalCore -- Instances
-import DataCon ( DataCon, dataConExTyVars, dataConRepArgTys,
- dataConName, dataConTyCon )
-import CoreSyn
+import PprExternalCore () -- Instances
+import DataCon
+import Coercion
import Var
import IdInfo
import Literal
import Name
-import NameSet ( NameSet, emptyNameSet )
-import UniqSet ( elementOfUniqSet )
+import NameSet
+import UniqSet
import Outputable
import ForeignCall
-import DynFlags ( DynFlags(..) )
-import StaticFlags ( opt_EmitExternalCore )
+import DynFlags
+import StaticFlags
import IO
import FastString
-- | null (tyConDataCons tcon) = error "MkExternalCore died: can't handle datatype declarations with no data constructors"
| otherwise =
C.Data (make_con_qid (tyConName tcon)) (map make_tbind tyvars) (map make_cdef (tyConDataCons tcon))
- where repclause | isRecursiveTyCon tcon = Nothing
+ where repclause | isRecursiveTyCon tcon || isOpenTyCon tcon= Nothing
| otherwise = Just (make_ty rep)
where (_, rep) = newTyConRep tcon
tyvars = tyConTyVars tcon
case globalIdDetails v of
-- a DataConId represents the Id of a worker, which is a varName. -- sof 4/02
-- DataConId _ -> C.Dcon (make_con_qid (Var.varName v))
- FCallId (CCall (CCallSpec (StaticTarget nm) _ _)) -> C.External (unpackFS nm) (make_ty (idType v))
- FCallId _ -> error "MkExternalCore died: can't handle non-static-C foreign call"
+ FCallId (CCall (CCallSpec (StaticTarget nm) callconv _))
+ -> C.External (unpackFS nm) (showSDoc (ppr callconv)) (make_ty (idType v))
+ FCallId (CCall (CCallSpec DynamicTarget callconv _))
+ -> C.DynExternal (showSDoc (ppr callconv)) (make_ty (idType v))
+ FCallId _
+ -> pprPanic "MkExternalCore died: can't handle non-{static,dynamic}-C foreign call"
+ (ppr v)
_ -> C.Var (make_var_qid (Var.varName v))
-make_exp (Lit (l@(MachLabel s _))) = error "MkExternalCore died: can't handle \"foreign label\" declarations"
+make_exp (Lit (l@(MachLabel s _))) = C.Label (unpackFS s)
make_exp (Lit l) = C.Lit (make_lit l)
make_exp (App e (Type t)) = C.Appt (make_exp e) (make_ty t)
make_exp (App e1 e2) = C.App (make_exp e1) (make_exp e2)
make_kind :: Kind -> C.Kind
-make_kind (PredTy p) | isEqPred p = panic "coercion kinds in external core not implemented!"
+make_kind (PredTy p) | isEqPred p = C.Keq (make_ty t1) (make_ty t2)
+ where (t1, t2) = getEqPredTys p
make_kind (FunTy k1 k2) = C.Karrow (make_kind k1) (make_kind k2)
make_kind k
| isLiftedTypeKind k = C.Klifted