From: sewardj <unknown>
Date: Thu, 9 Aug 2001 10:54:13 +0000 (+0000)
Subject: [project @ 2001-08-09 10:54:13 by sewardj]
X-Git-Tag: Approximately_9120_patches~1300
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=1222d1f1cd463d17cfd3109c5da8234b63117bf1;p=ghc-hetmet.git

[project @ 2001-08-09 10:54:13 by sewardj]
Add support for passing ptr/byte arrays to C.
---

diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs
index 5ef060e..5b0aa67 100644
--- a/ghc/compiler/ghci/ByteCodeGen.lhs
+++ b/ghc/compiler/ghci/ByteCodeGen.lhs
@@ -43,6 +43,8 @@ import Unique		( mkPseudoUnique3 )
 import FastString	( FastString(..) )
 import Panic		( GhcException(..) )
 import PprType		( pprType )
+import SMRep		( arrWordsHdrSize, arrPtrsHdrSize )
+import Constants	( wORD_SIZE )
 import ByteCodeInstr	( BCInstr(..), ProtoBCO(..), nameOfProtoBCO, bciStackUse )
 import ByteCodeItbls	( ItblEnv, mkITbls )
 import ByteCodeLink	( UnlinkedBCO, UnlinkedBCOExpr, assembleBCO,
@@ -660,11 +662,38 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l
                                          ]
                           in  pargs d_now az 		`thenBc` \ rest ->
                               returnBc ((code, AddrRep) : rest)
+
+                    ArrayRep
+                       -> pargs (d + addr_tsizeW) az	`thenBc` \ rest ->
+                          parg_ArrayishRep arrPtrsHdrSize d p a
+							`thenBc` \ code ->
+                          returnBc ((code,AddrRep):rest)
+
+                    ByteArrayRep
+                       -> pargs (d + addr_tsizeW) az	`thenBc` \ rest ->
+                          parg_ArrayishRep arrWordsHdrSize d p a
+							`thenBc` \ code ->
+                          returnBc ((code,AddrRep):rest)
+
                     -- Default case: push taggedly, but otherwise intact.
                     other
                        -> pushAtom True d p a		`thenBc` \ (code_a, sz_a) ->
                           pargs (d+sz_a) az		`thenBc` \ rest ->
                           returnBc ((code_a, rep_arg) : rest)
+
+         -- Do magic for Ptr/Byte arrays.  Push a ptr to the array on
+         -- the stack but then advance it over the headers, so as to
+         -- point to the payload.
+         parg_ArrayishRep hdrSizeW d p a
+            = pushAtom False{-irrel-} d p a `thenBc` \ (push_fo, _) ->
+              -- The ptr points at the header.  Advance it over the
+              -- header and then pretend this is an Addr# (push a tag).
+              returnBc (push_fo `snocOL` 
+                        SWIZZLE 0 (hdrSizeW * untaggedSizeW PtrRep
+                                            * wORD_SIZE) 
+                        `snocOL`
+                        PUSH_TAG addr_usizeW)
+
      in
          pargs d0 args_r_to_l				`thenBc` \ code_n_reps ->
      let
diff --git a/ghc/compiler/ghci/ByteCodeInstr.lhs b/ghc/compiler/ghci/ByteCodeInstr.lhs
index dcc96d9..7a965a1 100644
--- a/ghc/compiler/ghci/ByteCodeInstr.lhs
+++ b/ghc/compiler/ghci/ByteCodeInstr.lhs
@@ -101,6 +101,8 @@ data BCInstr
 
    -- For doing calls to C (via glue code generated by ByteCodeFFI)
    | CCALL            Addr	-- of the glue code
+   | SWIZZLE          Int Int	-- to the ptr N words down the stack,
+				-- add M (interpreted as a signed 16-bit entity)
 
    -- To Infinity And Beyond
    | ENTER
@@ -156,6 +158,8 @@ instance Outputable BCInstr where
    ppr (RETURN pk)           = text "RETURN  " <+> ppr pk
    ppr (CCALL marshall_addr) = text "CCALL   " <+> text "marshall code at" 
                                                <+> text (show marshall_addr)
+   ppr (SWIZZLE stkoff n)    = text "SWIZZLE " <+> text "stkoff" <+> int stkoff 
+                                               <+> text "by" <+> int n 
 
 -- The stack use, in words, of each bytecode insn.  These _must_ be
 -- correct, or overestimates of reality, to be safe.
@@ -186,6 +190,7 @@ bciStackUse (JMP lab)             = 0
 bciStackUse ENTER                 = 0
 bciStackUse (RETURN pk)           = 0
 bciStackUse (CCALL marshall_addr) = 0
+bciStackUse (SWIZZLE stkoff n)    = 0
 
 -- These insns actually reduce stack use, but we need the high-tide level,
 -- so can't use this info.  Not that it matters much.
diff --git a/ghc/compiler/ghci/ByteCodeLink.lhs b/ghc/compiler/ghci/ByteCodeLink.lhs
index 325dc00..70727f4 100644
--- a/ghc/compiler/ghci/ByteCodeLink.lhs
+++ b/ghc/compiler/ghci/ByteCodeLink.lhs
@@ -227,6 +227,7 @@ mkBits findLabel st proto_insns
        doInstr :: AsmState -> BCInstr -> IO AsmState
        doInstr st i
           = case i of
+               SWIZZLE   stkoff n -> instr3 st i_SWIZZLE stkoff n
                ARGCHECK  n        -> instr2 st i_ARGCHECK n
                STKCHECK  n        -> instr2 st i_STKCHECK n
                PUSH_L    o1       -> instr2 st i_PUSH_L o1
@@ -617,8 +618,10 @@ i_STKCHECK = (bci_STKCHECK :: Int)
 i_JMP      = (bci_JMP :: Int)
 #ifdef bci_CCALL
 i_CCALL    = (bci_CCALL :: Int)
+i_SWIZZLE  = (bci_SWIZZLE :: Int)
 #else
 i_CCALL    = error "Sorry pal, you need to bootstrap to use i_CCALL."
+i_SWIZZLE  = error "Sorry pal, you need to bootstrap to use i_SWIZZLE."
 #endif
 
 iNTERP_STACK_CHECK_THRESH = (INTERP_STACK_CHECK_THRESH :: Int)