X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FstgSyn%2FCoreToStg.lhs;h=9ddac59d4a56fc212904fc5daaaca71188acfc8a;hb=ec064b6d9d43b1655dd24df06d29b5e43940c7d6;hp=b2d725796d1250eeec37179d62e72b849f91c966;hpb=cbbee4e8727c583daf32d9bf17f00afaa839ef10;p=ghc-hetmet.git

diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs
index b2d7257..9ddac59 100644
--- a/compiler/stgSyn/CoreToStg.lhs
+++ b/compiler/stgSyn/CoreToStg.lhs
@@ -12,7 +12,7 @@ module CoreToStg ( coreToStg, coreExprToStg ) where
 #include "HsVersions.h"
 
 import CoreSyn
-import CoreUtils	( rhsIsStatic, exprType, findDefault )
+import CoreUtils	( exprType, findDefault )
 import CoreArity	( manifestArity )
 import StgSyn
 
@@ -184,7 +184,11 @@ coreTopBindToStg this_pkg env body_fvs (NonRec id rhs)
 	
 	bind = StgNonRec id stg_rhs
     in
-    ASSERT2(consistentCafInfo id bind, ppr id $$ ppr rhs $$ ppr bind )
+    ASSERT2(consistentCafInfo id bind, ppr id )
+      -- NB: previously the assertion printed 'rhs' and 'bind'
+      --     as well as 'id', but that led to a black hole
+      --     where printing the assertion error tripped the
+      --     assertion again!
     (env', fvs' `unionFVInfo` body_fvs, bind)
 
 coreTopBindToStg this_pkg env body_fvs (Rec pairs)
@@ -214,15 +218,14 @@ coreTopBindToStg this_pkg env body_fvs (Rec pairs)
 -- floated out a binding, in which case it will be approximate.
 consistentCafInfo :: Id -> GenStgBinding Var Id -> Bool
 consistentCafInfo id bind
-  | occNameFS (nameOccName (idName id)) == fsLit "sat"
-  = safe
-  | otherwise
-  = WARN (not exact, ppr id) safe
+  = WARN( not (exact || is_sat_thing) , ppr id ) 
+    safe
   where
-	safe  = id_marked_caffy || not binding_is_caffy
-	exact = id_marked_caffy == binding_is_caffy
-	id_marked_caffy  = mayHaveCafRefs (idCafInfo id)
-	binding_is_caffy = stgBindHasCafRefs bind
+    safe  = id_marked_caffy || not binding_is_caffy
+    exact = id_marked_caffy == binding_is_caffy
+    id_marked_caffy  = mayHaveCafRefs (idCafInfo id)
+    binding_is_caffy = stgBindHasCafRefs bind
+    is_sat_thing = occNameFS (nameOccName (idName id)) == fsLit "sat"
 \end{code}
 
 \begin{code}
@@ -236,13 +239,12 @@ coreToTopStgRhs this_pkg scope_fv_info (bndr, rhs)
   = do { (new_rhs, rhs_fvs, _) <- coreToStgExpr rhs
        ; lv_info <- freeVarsToLiveVars rhs_fvs
 
-       ; let stg_rhs   = mkTopStgRhs is_static rhs_fvs (mkSRT lv_info) bndr_info new_rhs
+       ; let stg_rhs   = mkTopStgRhs this_pkg rhs_fvs (mkSRT lv_info) bndr_info new_rhs
              stg_arity = stgRhsArity stg_rhs
        ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs, 
                  rhs_fvs) }
   where
     bndr_info = lookupFVInfo scope_fv_info bndr
-    is_static = rhsIsStatic this_pkg rhs
 
 	-- It's vital that the arity on a top-level Id matches
 	-- the arity of the generated STG binding, else an importing 
@@ -263,25 +265,23 @@ coreToTopStgRhs this_pkg scope_fv_info (bndr, rhs)
                 ptext (sLit "Id arity:") <+> ppr id_arity,
                 ptext (sLit "STG arity:") <+> ppr stg_arity]
 
-mkTopStgRhs :: Bool -> FreeVarsInfo
+mkTopStgRhs :: PackageId -> FreeVarsInfo
 	    -> SRT -> StgBinderInfo -> StgExpr
    	    -> StgRhs
 
-mkTopStgRhs is_static rhs_fvs srt binder_info (StgLam _ bndrs body)
-  = ASSERT( is_static )
-    StgRhsClosure noCCS binder_info
+mkTopStgRhs _ rhs_fvs srt binder_info (StgLam _ bndrs body)
+  = StgRhsClosure noCCS binder_info
 		  (getFVs rhs_fvs)		 
 		  ReEntrant
 		  srt
 		  bndrs body
 
-mkTopStgRhs is_static _ _ _ (StgConApp con args)
-  | is_static	 -- StgConApps can be updatable (see isCrossDllConApp)
+mkTopStgRhs this_pkg _ _ _ (StgConApp con args)
+  | not (isDllConApp this_pkg con args)  -- Dynamic StgConApps are updatable
   = StgRhsCon noCCS con args
 
-mkTopStgRhs is_static rhs_fvs srt binder_info rhs
-  = ASSERT2( not is_static, ppr rhs )
-    StgRhsClosure noCCS binder_info
+mkTopStgRhs _ rhs_fvs srt binder_info rhs
+  = StgRhsClosure noCCS binder_info
 		  (getFVs rhs_fvs)		 
 	          Updatable
 		  srt
@@ -437,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
 
@@ -445,7 +445,7 @@ mkStgAltType bndr alts
    _is_poly_alt_tycon tc
 	=  isFunTyCon tc
         || isPrimTyCon tc   -- "Any" is lifted but primitive
-	|| isOpenTyCon tc   -- Type family; e.g. arising from strict
+	|| isFamilyTyCon tc   -- Type family; e.g. arising from strict
 			    -- function application where argument has a
 			    -- type-family type
 
@@ -528,15 +528,20 @@ coreToStgApp _ f args = do
 	res_ty = exprType (mkApps (Var f) args)
 	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
-		FCallId (CCall (CCallSpec (StaticTarget lbl) PrimCallConv _))
-                                 -- prim calls are represented as FCalls in core,
-                                 -- but in stg we distinguish them
-				 -> ASSERT( saturated )
-                                    StgOpApp (StgPrimCallOp (PrimCall lbl)) 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'
 
@@ -1115,7 +1120,7 @@ myCollectArgs expr
     go (Cast e _)       as = go e as
     go (Note _ e)       as = go e as
     go (Lam b e)        as
-       | isTyVar b         = go e as	-- Note [Collect args]
+       | isTyCoVar b         = go e as	-- Note [Collect args]
     go _                _  = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
 \end{code}