[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 (file)
--- 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 (file)
--- 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 (file)
--- 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)