Refactor PackageTarget back into StaticTarget

[ghc-hetmet.git] / compiler / stgSyn / CoreToStg.lhs

diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs
index d11dc75..edda603 100644 (file)
--- a/compiler/stgSyn/CoreToStg.lhs
+++ b/compiler/stgSyn/CoreToStg.lhs
@@ -12,7 +12,8 @@ module CoreToStg ( coreToStg, coreExprToStg ) where
 #include "HsVersions.h"
 
 import CoreSyn
-import CoreUtils       ( rhsIsStatic, manifestArity, exprType, findDefault )
+import CoreUtils       ( rhsIsStatic, exprType, findDefault )
+import CoreArity       ( manifestArity )
 import StgSyn
 
 import Type
@@ -33,6 +34,8 @@ import Outputable
 import MonadUtils
 import FastString
 import Util
+import ForeignCall
+import PrimOp          ( PrimCall(..) )
 \end{code}
 
 %************************************************************************
@@ -434,7 +437,7 @@ mkStgAltType bndr alts
                    | isUnLiftedTyCon tc     -> PrimAlt tc
                    | isHiBootTyCon tc       -> look_for_better_tycon
                    | isAlgTyCon tc          -> AlgAlt tc
-                   | otherwise              -> ASSERT( _is_poly_alt_tycon tc )
+                   | otherwise              -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )
                                                PolyAlt
        Nothing                              -> PolyAlt
 
@@ -523,12 +526,22 @@ coreToStgApp _ f args = do
        --         two regardless.
 
        res_ty = exprType (mkApps (Var f) args)
-       app = case globalIdDetails f of
+       app = case idDetails f of
                DataConWorkId dc | saturated -> StgConApp dc args'
+
+               -- Some primitive operator that might be implemented as a library call.
                PrimOpId op      -> ASSERT( saturated )
                                    StgOpApp (StgPrimOp op) args' res_ty
+
+               -- A call to some primitive Cmm function.
+               FCallId (CCall (CCallSpec (StaticTarget lbl (Just pkgId)) PrimCallConv _))
+                                -> ASSERT( saturated )
+                                   StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty
+
+               -- A regular foreign call.
                FCallId call     -> ASSERT( saturated )
                                    StgOpApp (StgFCallOp call (idUnique f)) args' res_ty
+
                 TickBoxOpId {}   -> pprPanic "coreToStg TickBox" $ ppr (f,args')
                _other           -> StgApp f args'