Refactor PackageTarget back into StaticTarget

[ghc-hetmet.git] / compiler / codeGen / StgCmmForeign.hs

diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs
index 2735b69..b98da50 100644 (file)
--- a/compiler/codeGen/StgCmmForeign.hs
+++ b/compiler/codeGen/StgCmmForeign.hs
@@ -1,6 +1,3 @@
-{-# OPTIONS -w #-}
--- Lots of missing type sigs etc
-
 -----------------------------------------------------------------------------
 --
 -- Code generation for foreign calls.
@@ -29,20 +26,18 @@ import StgCmmClosure
 import BlockId
 import Cmm
 import CmmUtils
-import MkZipCfg
 import MkZipCfgCmm hiding (CmmAGraph)
 import Type
 import TysPrim
-import UniqSupply
 import CLabel
 import SMRep
 import ForeignCall
 import Constants
 import StaticFlags
-import FastString
 import Maybes
 import Outputable
 import ZipCfgCmmRep
+import BasicTypes
 
 import Control.Monad
 
@@ -59,19 +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)))
-                  DynamicTarget    ->  case args of fn:rest -> (rest, fn)
-             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
@@ -82,17 +86,14 @@ 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 
          -> [(CmmActual,ForeignHint)]
          -> FCode ()
 emitCCall hinted_results fn hinted_args
-  = emitForeignCall PlayRisky results (ForeignTarget fn fc) args 
+  = emitForeignCall PlayRisky results target args
                    NoC_SRT -- No SRT b/c we PlayRisky
                    CmmMayReturn
   where
@@ -102,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
@@ -116,10 +117,9 @@ emitForeignCall
         -> CmmReturnInfo       -- This can say "never returns"
                                --   only RTS procedures do this
        -> FCode ()
-emitForeignCall safety results target args _srt ret
+emitForeignCall safety results target args _srt _ret
   | not (playSafe safety) = do
     let (caller_save, caller_load) = callerSaveVolatileRegs
-    updfr_off <- getUpdFrameOff
     emit caller_save
     emit $ mkUnsafeCall target results args
     emit caller_load
@@ -145,12 +145,14 @@ load_args_into_temps = mapM arg_assign_temp
           return (tmp,hint)
 -}
        
+load_target_into_temp :: MidCallTarget -> FCode MidCallTarget
 load_target_into_temp (ForeignTarget expr conv) = do 
   tmp <- maybe_assign_temp expr
   return (ForeignTarget tmp conv)
 load_target_into_temp other_target@(PrimTarget _) =
   return other_target
 
+maybe_assign_temp :: CmmExpr -> FCode CmmExpr
 maybe_assign_temp e
   | hasNoGlobalRegs e = return e
   | otherwise         = do 
@@ -235,10 +237,12 @@ openNursery = catAGraphs [
 emitOpenNursery :: FCode ()
 emitOpenNursery = emit openNursery
 
+nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: CmmExpr
 nursery_bdescr_free   = cmmOffset stgCurrentNursery oFFSET_bdescr_free
 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
@@ -253,11 +257,13 @@ tsoFieldB off
 tsoProfFieldB :: ByteOff -> ByteOff
 tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
 
+stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr
 stgSp            = CmmReg sp
 stgHp            = CmmReg hp
 stgCurrentTSO    = CmmReg currentTSO
 stgCurrentNursery = CmmReg currentNursery
 
+sp, spLim, hp, hpLim, currentTSO, currentNursery :: CmmReg
 sp               = CmmGlobal Sp
 spLim            = CmmGlobal SpLim
 hp               = CmmGlobal Hp