[project @ 2002-01-29 13:22:28 by sewardj]

Teach the NCG how to do f-i-dynamic.  Nothing unexpected.
sparc-side now needs fixing.

7 files changed, 78 insertions, 45 deletions

diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs
index e120d80e5b..ac2944cdc2 100644
--- a/ghc/compiler/nativeGen/MachCode.lhs
+++ b/ghc/compiler/nativeGen/MachCode.lhs
@@ -63,6 +63,11 @@ order.
 type InstrBlock = OrdList Instr
 
 x `bind` f = f x
+
+isLeft (Left _)  = True
+isLeft (Right _) = False
+
+unLeft (Left x) = x
 \end{code}
 
 Code extractor for an entire stix tree---stix statement level.
@@ -156,7 +161,8 @@ derefDLL tree
                 StIndex pk base offset -> StIndex pk (qq base) (qq offset)
                 StMachOp mop args      -> StMachOp mop (map qq args)
                 StInd pk addr          -> StInd pk (qq addr)
-                StCall who cc pk args  -> StCall who cc pk (map qq args)
+                StCall (Left nm) cc pk args -> StCall (Left nm) cc pk (map qq args)
+                StCall (Right f) cc pk args -> StCall (Right (qq f)) cc pk (map qq args)
                 StInt    _             -> t
                 StFloat  _             -> t
                 StDouble _             -> t
@@ -878,8 +884,8 @@ getRegister (StMachOp mop [x]) -- unary MachOps
       other_op 
          -> getRegister (
                (if is_float_op then demote else id)
-               (StCall fn CCallConv DoubleRep 
-                          [(if is_float_op then promote else id) x])
+               (StCall (Left fn) CCallConv DoubleRep 
+                       [(if is_float_op then promote else id) x])
             )
       where
         integerExtend signed nBits x
@@ -991,11 +997,11 @@ getRegister (StMachOp mop [x, y]) -- dyadic MachOps
       MO_Nat_Sar  -> shift_code (SAR L) x y {-False-}
 
       MO_Flt_Pwr  -> getRegister (demote 
-                                 (StCall SLIT("pow") CCallConv DoubleRep 
-                                           [promote x, promote y])
+                                 (StCall (Left SLIT("pow")) CCallConv DoubleRep 
+                                         [promote x, promote y])
                                  )
-      MO_Dbl_Pwr -> getRegister (StCall SLIT("pow") CCallConv DoubleRep 
-                                           [x, y])
+      MO_Dbl_Pwr -> getRegister (StCall (Left SLIT("pow")) CCallConv DoubleRep 
+                                        [x, y])
       other -> pprPanic "getRegister(x86) - binary StMachOp (1)" (pprMachOp mop)
   where
     promote x = StMachOp MO_Flt_to_Dbl [x]
@@ -2617,7 +2623,7 @@ register allocator.
 
 \begin{code}
 genCCall
-    :: FAST_STRING	-- function to call
+    :: (Either FAST_STRING StixExpr)	-- function to call
     -> CCallConv
     -> PrimRep		-- type of the result
     -> [StixExpr]	-- arguments (of mixed type)
@@ -2698,12 +2704,12 @@ genCCall fn cconv kind args
 #if i386_TARGET_ARCH
 
 genCCall fn cconv ret_rep [StInt i]
-  | fn == SLIT ("PerformGC_wrapper")
+  | isLeft fn && unLeft fn == SLIT ("PerformGC_wrapper")
   = let call = toOL [
                   MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
-	          CALL (ImmLit (ptext (if   underscorePrefix 
+	          CALL (Left (ImmLit (ptext (if   underscorePrefix 
                                        then (SLIT ("_PerformGC_wrapper"))
-                                       else (SLIT ("PerformGC_wrapper")))))
+                                       else (SLIT ("PerformGC_wrapper"))))))
                ]
     in
     returnNat call
@@ -2711,32 +2717,41 @@ genCCall fn cconv ret_rep [StInt i]
 
 genCCall fn cconv ret_rep args
   = mapNat push_arg
-           (reverse args)  `thenNat` \ sizes_n_codes ->
-    getDeltaNat            `thenNat` \ delta ->
-    let (sizes, codes) = unzip sizes_n_codes
-        tot_arg_size   = sum sizes
-	code2          = concatOL codes
-	call = toOL (
-                  [CALL (fn__2 tot_arg_size)]
-                  ++
+           (reverse args)  	`thenNat` \ sizes_n_codes ->
+    getDeltaNat            	`thenNat` \ delta ->
+    let (sizes, push_codes) = unzip sizes_n_codes
+        tot_arg_size        = sum sizes
+    in
+    -- deal with static vs dynamic call targets
+    (case fn of
+        Left t_static 
+           -> returnNat (unitOL (CALL (Left (fn__2 tot_arg_size))))
+        Right dyn 
+           -> get_op dyn `thenNat` \ (dyn_c, dyn_r, dyn_rep) ->
+              ASSERT(dyn_rep == L)
+              returnNat (dyn_c `snocOL` CALL (Right dyn_r))
+    ) 
+				`thenNat` \ callinsns ->
+    let	push_code = concatOL push_codes
+	call = callinsns `appOL`
+               toOL (
 			-- Deallocate parameters after call for ccall;
 			-- but not for stdcall (callee does it)
                   (if cconv == StdCallConv then [] else 
 		   [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
                   ++
-
                   [DELTA (delta + tot_arg_size)]
                )
     in
     setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
-    returnNat (code2 `appOL` call)
+    returnNat (push_code `appOL` call)
 
   where
     -- function names that begin with '.' are assumed to be special
     -- internally generated names like '.mul,' which don't get an
     -- underscore prefix
     -- ToDo:needed (WDP 96/03) ???
-    fn_u  = _UNPK_ fn
+    fn_u  = _UNPK_ (unLeft fn)
     fn__2 tot_arg_size
        | head fn_u == '.'
        = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
diff --git a/ghc/compiler/nativeGen/MachMisc.lhs b/ghc/compiler/nativeGen/MachMisc.lhs
index ad711882d5..c29aee43a9 100644
--- a/ghc/compiler/nativeGen/MachMisc.lhs
+++ b/ghc/compiler/nativeGen/MachMisc.lhs
@@ -572,7 +572,7 @@ but we don't care, since it doesn't get used much.  We hope.
 
 	      | JMP	      DestInfo Operand -- possible dests, target
 	      | JXX	      Cond CLabel -- target
-	      | CALL	      Imm
+	      | CALL	      (Either Imm Reg)
 
 -- Other things.
 
diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs
index e65a6a348b..ae2aa96df6 100644
--- a/ghc/compiler/nativeGen/PprMach.lhs
+++ b/ghc/compiler/nativeGen/PprMach.lhs
@@ -971,8 +971,8 @@ pprInstr (POP size op) = pprSizeOp SLIT("pop") size op
 pprInstr PUSHA = ptext SLIT("\tpushal")
 pprInstr POPA = ptext SLIT("\tpopal")
 
-pprInstr (NOP) = ptext SLIT("\tnop")
-pprInstr (CLTD) = ptext SLIT("\tcltd")
+pprInstr NOP = ptext SLIT("\tnop")
+pprInstr CLTD = ptext SLIT("\tcltd")
 
 pprInstr (SETCC cond op) = pprCondInstr SLIT("set") cond (pprOperand B op)
 
@@ -980,7 +980,8 @@ pprInstr (JXX cond lab) = pprCondInstr SLIT("j") cond (pprCLabel_asm lab)
 
 pprInstr (JMP dsts (OpImm imm)) = (<>) (ptext SLIT("\tjmp ")) (pprImm imm)
 pprInstr (JMP dsts op)          = (<>) (ptext SLIT("\tjmp *")) (pprOperand L op)
-pprInstr (CALL imm)             = (<>) (ptext SLIT("\tcall ")) (pprImm imm)
+pprInstr (CALL (Left imm))      = (<>) (ptext SLIT("\tcall ")) (pprImm imm)
+pprInstr (CALL (Right reg))     = (<>) (ptext SLIT("\tcall *")) (pprReg L reg)
 
 -- First bool indicates signedness; second whether quot or rem
 pprInstr (IQUOT sz src dst) = pprInstr_quotRem True True sz src dst
diff --git a/ghc/compiler/nativeGen/RegAllocInfo.lhs b/ghc/compiler/nativeGen/RegAllocInfo.lhs
index f1149aca1c..0791d5d092 100644
--- a/ghc/compiler/nativeGen/RegAllocInfo.lhs
+++ b/ghc/compiler/nativeGen/RegAllocInfo.lhs
@@ -259,7 +259,8 @@ regUsage instr = case instr of
     SETCC  cond op	-> mkRU [] (def_W op)
     JXX    cond lbl	-> mkRU [] []
     JMP    dsts op	-> mkRU (use_R op) []
-    CALL   imm		-> mkRU [] callClobberedRegs
+    CALL   (Left imm)	-> mkRU [] callClobberedRegs
+    CALL   (Right reg)	-> mkRU [reg] callClobberedRegs
     CLTD		-> mkRU [eax] [edx]
     NOP			-> mkRU [] []
 
@@ -679,6 +680,9 @@ patchRegs instr env = case instr of
     GCOS sz src dst	-> GCOS sz (env src) (env dst)
     GTAN sz src dst	-> GTAN sz (env src) (env dst)
 
+    CALL (Left imm)	-> instr
+    CALL (Right reg)	-> CALL (Right (env reg))
+
     COMMENT _		-> instr
     SEGMENT _ 		-> instr
     LABEL _		-> instr
@@ -686,7 +690,6 @@ patchRegs instr env = case instr of
     DATA _ _		-> instr
     DELTA _ 		-> instr
     JXX _ _		-> instr
-    CALL _		-> instr
     CLTD		-> instr
     _			-> pprPanic "patchRegs(x86)" empty
 
diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs
index 573496c981..199087d256 100644
--- a/ghc/compiler/nativeGen/Stix.lhs
+++ b/ghc/compiler/nativeGen/Stix.lhs
@@ -150,7 +150,8 @@ data StixExpr
   | StMachOp MachOp [StixExpr]
 
     -- Calls to C functions
-  | StCall FAST_STRING CCallConv PrimRep [StixExpr]
+  | StCall (Either FAST_STRING StixExpr) -- Left: static, Right: dynamic
+           CCallConv PrimRep [StixExpr]
 
 
 -- What's the PrimRep of the value denoted by this StixExpr?
@@ -206,10 +207,14 @@ pprStixExpr t
        StReg reg        -> pprStixReg reg
        StMachOp op args -> pprMachOp op 
                            <> parens (hsep (punctuate comma (map pprStixExpr args)))
-       StCall nm cc k args
-                        -> parens (text "Call" <+> ptext nm <+>
+       StCall fn cc k args
+                        -> parens (text "Call" <+> targ <+>
                                    ppr cc <+> ppr k <+> 
                                    hsep (map pprStixExpr args))
+                           where
+                              targ = case fn of
+                                        Left  t_static -> ptext t_static
+                                        Right t_dyn    -> parens (pprStixExpr t_dyn)
 
 pprStixStmt :: StixStmt -> SDoc
 pprStixStmt t 
@@ -341,7 +346,8 @@ stixExpr_CountTempUses u t
         StIndex    pk t1 t2       -> qe t1 + qe t2
         StInd      pk t1          -> qe t1
         StMachOp   mop ts         -> sum (map qe ts)
-        StCall     nm cconv pk ts -> sum (map qe ts)
+        StCall     (Left nm) cconv pk ts -> sum (map qe ts)
+        StCall     (Right f) cconv pk ts -> sum (map qe ts) + qe f
         StInt _          -> 0
         StFloat _        -> 0
         StDouble _       -> 0
@@ -403,7 +409,8 @@ stixExpr_MapUniques f t
         StIndex    pk t1 t2       -> StIndex    pk (qe t1) (qe t2)
         StInd      pk t1          -> StInd      pk (qe t1)
         StMachOp   mop args       -> StMachOp   mop (map qe args)
-        StCall     nm cconv pk ts -> StCall     nm cconv pk (map qe ts)
+        StCall     (Left nm) cconv pk ts -> StCall (Left nm) cconv pk (map qe ts)
+        StCall     (Right f) cconv pk ts -> StCall (Right (qe f)) cconv pk (map qe ts)
         StInt _          -> t
         StFloat _        -> t
         StDouble _       -> t
diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs
index 141cf98286..a57c95128a 100644
--- a/ghc/compiler/nativeGen/StixMacro.lhs
+++ b/ghc/compiler/nativeGen/StixMacro.lhs
@@ -72,7 +72,7 @@ adding an indirection.
 macroCode UPD_CAF args
   = let
 	[cafptr,bhptr] = map amodeToStix args
-	new_caf = StVoidable (StCall SLIT("newCAF") CCallConv VoidRep [cafptr])
+	new_caf = StVoidable (StCall (Left SLIT("newCAF")) CCallConv VoidRep [cafptr])
 	a1 = StAssignMem PtrRep (StIndex PtrRep cafptr fixedHS) bhptr
 	a2 = StAssignMem PtrRep cafptr ind_static_info
     in
@@ -178,7 +178,8 @@ macroCode REGISTER_IMPORT [arg]
 macroCode REGISTER_FOREIGN_EXPORT [arg]
    = returnUs (
 	\xs -> StVoidable (
-                  StCall SLIT("getStablePtr") CCallConv VoidRep [amodeToStix arg]
+                  StCall (Left SLIT("getStablePtr")) CCallConv VoidRep 
+                         [amodeToStix arg]
                )
 	     : xs
      )
diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs
index c70a2373e6..6d6db5819a 100644
--- a/ghc/compiler/nativeGen/StixPrim.lhs
+++ b/ghc/compiler/nativeGen/StixPrim.lhs
@@ -64,7 +64,7 @@ rather than inheriting the calling convention of the thing which we're really
 calling.
 
 \begin{code}
-foreignCallCode lhs (CCall (CCallSpec (StaticTarget fn) cconv safety)) rhs
+foreignCallCode lhs call@(CCall (CCallSpec ctarget cconv safety)) rhs
 
   | not (playSafe safety) 
   = returnUs (\xs -> ccall : xs)
@@ -77,16 +77,25 @@ foreignCallCode lhs (CCall (CCallSpec (StaticTarget fn) cconv safety)) rhs
        id  = StixTemp (StixVReg uniq IntRep)
     
        suspend = StAssignReg IntRep id 
-   		 (StCall SLIT("suspendThread") {-no:cconv-} CCallConv
+   		 (StCall (Left SLIT("suspendThread")) {-no:cconv-} CCallConv
                          IntRep [StReg stgBaseReg])
        resume  = StVoidable 
-                 (StCall SLIT("resumeThread") {-no:cconv-} CCallConv
+                 (StCall (Left SLIT("resumeThread")) {-no:cconv-} CCallConv
                          VoidRep [StReg id])
     in
     returnUs (\xs -> save (suspend : ccall : resume : load xs))
 
   where
-    args = map amodeCodeForCCall rhs
+    (cargs, stix_target)
+        = case ctarget of
+             StaticTarget nm -> (rhs, Left nm)
+             DynamicTarget |  not (null rhs) -- an assertion
+                           -> (tail rhs, Right (amodeToStix (head rhs)))
+             CasmTarget _
+                -> ncgPrimopMoan "Native code generator can't handle foreign call" 
+                                 (ppr call)
+
+    stix_args = map amodeCodeForCCall cargs
     amodeCodeForCCall x =
 	let base = amodeToStix' x
 	in
@@ -94,11 +103,11 @@ foreignCallCode lhs (CCall (CCallSpec (StaticTarget fn) cconv safety)) rhs
 	      ArrayRep      -> StIndex PtrRep base arrPtrsHS
 	      ByteArrayRep  -> StIndex IntRep base arrWordsHS
 	      ForeignObjRep -> StInd PtrRep (StIndex PtrRep base fixedHS)
-	      _ -> base
+	      other         -> base
 
     ccall = case lhs of
-      []    -> StVoidable (StCall fn cconv VoidRep args)
-      [lhs] -> mkStAssign pk lhs' (StCall fn cconv pk args)
+      []    -> StVoidable (StCall stix_target cconv VoidRep stix_args)
+      [lhs] -> mkStAssign pk lhs' (StCall stix_target cconv pk stix_args)
 	    where
 	       lhs' = amodeToStix lhs
 	       pk   = case getAmodeRep lhs of
@@ -107,9 +116,6 @@ foreignCallCode lhs (CCall (CCallSpec (StaticTarget fn) cconv safety)) rhs
                         Int64Rep  -> Int64Rep
                         Word64Rep -> Word64Rep
                         other     -> IntRep
-
-foreignCallCode lhs call rhs
-  = ncgPrimopMoan "Native code generator can't handle foreign call" (ppr call)
 \end{code}
 
 %************************************************************************