X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcodeGen%2FStgCmmForeign.hs;h=7ddf597f4036f40fc5383277b3eeb1eb5bdb99e3;hb=4b2dd6b968640830631b4071b962c47c541f9722;hp=b8a725520f8c3bed33bcf33660334a7a33f02cb7;hpb=232e72122fa7f08690e3be2bb9f8a7f8024e37d5;p=ghc-hetmet.git

diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs
index b8a7255..7ddf597 100644
--- a/compiler/codeGen/StgCmmForeign.hs
+++ b/compiler/codeGen/StgCmmForeign.hs
@@ -54,21 +54,28 @@ cgForeignCall :: [LocalReg]		-- r1,r2  where to put the results
 
 cgForeignCall results result_hints (CCall (CCallSpec target cconv safety)) stg_args
   = do	{ cmm_args <- getFCallArgs stg_args
-	; let (args, arg_hints) = unzip cmm_args
-	      fc = ForeignConvention cconv arg_hints result_hints
-	      (call_args, cmm_target)
-		= case target of
-		   StaticTarget lbl -> (args, CmmLit (CmmLabel 
-						(mkForeignLabel lbl (call_size args) False IsFunction)))
-		   DynamicTarget    ->  case args of
-                                        fn:rest -> (rest, fn)
-                                        [] -> panic "cgForeignCall []"
-	      call_target = ForeignTarget cmm_target fc
-	
-	; srt <- getSRTInfo NoSRT	-- SLPJ: Not sure what SRT 
-					-- is right here
+        ; let ((call_args, arg_hints), cmm_target)
+                = case target of
+                   StaticTarget lbl mPkgId 
+		     -> let labelSource
+				= case mPkgId of
+					Nothing		-> ForeignLabelInThisPackage
+					Just pkgId	-> ForeignLabelInPackage pkgId
+			    size	= call_size cmm_args
+			in  ( unzip cmm_args
+			    , CmmLit (CmmLabel 
+					(mkForeignLabel lbl size labelSource IsFunction)))
+ 
+                   DynamicTarget    ->  case cmm_args of
+                                           (fn,_):rest -> (unzip rest, fn)
+                                           [] -> panic "cgForeignCall []"
+              fc = ForeignConvention cconv arg_hints result_hints
+              call_target = ForeignTarget cmm_target fc
+        
+        ; srt <- getSRTInfo NoSRT        -- SLPJ: Not sure what SRT 
+                                        -- is right here
                                         -- JD: Does it matter in the new codegen?
-	; emitForeignCall safety results call_target call_args srt CmmMayReturn }
+        ; emitForeignCall safety results call_target call_args srt CmmMayReturn }
   where
 	-- in the stdcall calling convention, the symbol needs @size appended
 	-- to it, where size is the total number of bytes of arguments.  We
@@ -79,10 +86,7 @@ cgForeignCall results result_hints (CCall (CCallSpec target cconv safety)) stg_a
 	| otherwise            = Nothing
 
 	-- ToDo: this might not be correct for 64-bit API
-      arg_size arg = max (widthInBytes $ typeWidth $ cmmExprType arg) wORD_SIZE
-
-cgForeignCall _ _ (DNCall _) _
-  = panic "cgForeignCall: DNCall"
+      arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType arg) wORD_SIZE
 
 emitCCall :: [(CmmFormal,ForeignHint)]
 	  -> CmmExpr 
@@ -99,9 +103,9 @@ emitCCall hinted_results fn hinted_args
     fc = ForeignConvention CCallConv arg_hints result_hints
     
 
-emitPrimCall :: CmmFormal -> CallishMachOp -> CmmActuals -> FCode ()
+emitPrimCall :: CmmFormals -> CallishMachOp -> CmmActuals -> FCode ()
 emitPrimCall res op args
-  = emitForeignCall PlayRisky [res] (PrimTarget op) args NoC_SRT CmmMayReturn
+  = emitForeignCall PlayRisky res (PrimTarget op) args NoC_SRT CmmMayReturn
 
 -- alternative entry point, used by CmmParse
 emitForeignCall
@@ -123,7 +127,7 @@ emitForeignCall safety results target args _srt _ret
   | otherwise = do
     updfr_off <- getUpdFrameOff
     temp_target <- load_target_into_temp target
-    emit $ mkSafeCall temp_target results args updfr_off
+    emit $ mkSafeCall temp_target results args updfr_off (playInterruptible safety)
 
 
 {-
@@ -239,10 +243,12 @@ nursery_bdescr_start  = cmmOffset stgCurrentNursery oFFSET_bdescr_start
 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
 
 tso_SP, tso_STACK, tso_CCCS :: ByteOff
-tso_SP    = tsoFieldB     oFFSET_StgTSO_sp
-tso_STACK = tsoFieldB     oFFSET_StgTSO_stack
 tso_CCCS  = tsoProfFieldB oFFSET_StgTSO_CCCS
 
+ --ToDo: needs merging with changes to CgForeign
+tso_STACK = tsoFieldB     undefined
+tso_SP    = tsoFieldB     undefined
+
 -- The TSO struct has a variable header, and an optional StgTSOProfInfo in
 -- the middle.  The fields we're interested in are after the StgTSOProfInfo.
 tsoFieldB :: ByteOff -> ByteOff