Commit 2cc5b907 authored by simonmar's avatar simonmar

[project @ 2002-02-12 15:17:13 by simonmar]

Switch over to the new hierarchical libraries
---------------------------------------------

This commit reorganises our libraries to use the new hierarchical
module namespace extension.

The basic story is this:

   - fptools/libraries contains the new hierarchical libraries.
     Everything in here is "clean", i.e. most deprecated stuff has
     been removed.

	- fptools/libraries/base is the new base package
	  (replacing "std") and contains roughly what was previously
	  in std, lang, and concurrent, minus deprecated stuff.
	  Things that are *not allowed* in libraries/base include:
		Addr, ForeignObj, ByteArray, MutableByteArray,
		_casm_, _ccall_, ``'', PrimIO

	  For ByteArrays and MutableByteArrays we use UArray and
	  STUArray/IOUArray respectively now.

	  Modules previously called PrelFoo are now under
	  fptools/libraries/GHC.  eg. PrelBase is now GHC.Base.

	- fptools/libraries/haskell98 provides the Haskell 98 std.
	  libraries (Char, IO, Numeric etc.) as a package.  This
	  package is enabled by default.

	- fptools/libraries/network is a rearranged version of
	  the existing net package (the old package net is still
	  available; see below).

	- Other packages will migrate to fptools/libraries in
	  due course.

     NB. you need to checkout fptools/libraries as well as
     fptools/hslibs now.  The nightly build scripts will need to be
     tweaked.

   - fptools/hslibs still contains (almost) the same stuff as before.
     Where libraries have moved into the new hierarchy, the hslibs
     version contains a "stub" that just re-exports the new version.
     The idea is that code will gradually migrate from fptools/hslibs
     into fptools/libraries as it gets cleaned up, and in a version or
     two we can remove the old packages altogether.

   - I've taken the opportunity to make some changes to the build
     system, ripping out the old hslibs Makefile stuff from
     mk/target.mk; the new package building Makefile code is in
     mk/package.mk (auto-included from mk/target.mk).

     The main improvement is that packages now register themselves at
     make boot time using ghc-pkg, and the monolithic package.conf
     in ghc/driver is gone.

     I've updated the standard packages but haven't tested win32,
     graphics, xlib, object-io, or OpenGL yet.  The Makefiles in
     these packages may need some further tweaks, and they'll need
     pkg.conf.in files added.

   - Unfortunately all this rearrangement meant I had to bump the
     interface-file version and create a bunch of .hi-boot-6 files :-(
parent 239e9471
#-----------------------------------------------------------------------------
# $Id: Makefile,v 1.19 2001/10/24 10:07:57 rrt Exp $
# $Id: Makefile,v 1.20 2002/02/12 15:17:13 simonmar Exp $
#
TOP=.
......@@ -21,13 +21,13 @@ include $(TOP)/mk/boilerplate.mk
# we descend into compiler/ and lib/.
#
ifeq "$(BootingFromHc)" "YES"
SUBDIRS = includes utils rts docs lib compiler driver
SUBDIRS = includes utils rts docs compiler driver
else
ifneq "$(ILXized)" "YES"
SUBDIRS = includes utils driver docs compiler rts lib
SUBDIRS = includes utils driver docs compiler rts
else
# No RTS for ILX
SUBDIRS = includes utils driver docs compiler lib
SUBDIRS = includes utils driver docs compiler
endif
endif
......
# -----------------------------------------------------------------------------
# $Id: Makefile,v 1.209 2002/02/11 08:20:38 chak Exp $
# $Id: Makefile,v 1.210 2002/02/12 15:17:13 simonmar Exp $
TOP = ..
......@@ -61,17 +61,18 @@ $(CONFIG_HS) : $(FPTOOLS_TOP)/mk/config.mk Makefile
@echo "cRAWCPP_FLAGS = \"$(RAWCPP_FLAGS)\"" >> $(CONFIG_HS)
@echo "cGCC = \"$(WhatGccIsCalled)\"" >> $(CONFIG_HS)
@echo "cMKDLL = \"$(BLD_DLL)\"" >> $(CONFIG_HS)
@echo "cGHC_DRIVER_DIR = \"$(GHC_DRIVER_DIR)\"" >> $(CONFIG_HS)
@echo "cGHC_TOUCHY = \"$(GHC_TOUCHY)\"" >> $(CONFIG_HS)
@echo "cGHC_TOUCHY_DIR = \"$(GHC_TOUCHY_DIR)\"" >> $(CONFIG_HS)
@echo "cGHC_UNLIT = \"$(GHC_UNLIT)\"" >> $(CONFIG_HS)
@echo "cGHC_UNLIT_DIR = \"$(GHC_UNLIT_DIR)\"" >> $(CONFIG_HS)
@echo "cGHC_MANGLER = \"$(GHC_MANGLER)\"" >> $(CONFIG_HS)
@echo "cGHC_MANGLER_DIR = \"$(GHC_MANGLER_DIR)\"" >> $(CONFIG_HS)
@echo "cGHC_SPLIT = \"$(GHC_SPLIT)\"" >> $(CONFIG_HS)
@echo "cGHC_SPLIT_DIR = \"$(GHC_SPLIT_DIR)\"" >> $(CONFIG_HS)
@echo "cGHC_SYSMAN = \"$(GHC_SYSMAN)\"" >> $(CONFIG_HS)
@echo "cGHC_SYSMAN_DIR = \"$(GHC_SYSMAN_DIR)\"" >> $(CONFIG_HS)
@echo "cPROJECT_DIR = \"$(PROJECT_DIR)\"" >> $(CONFIG_HS)
@echo "cGHC_DRIVER_DIR_REL = \"$(GHC_DRIVER_DIR_REL)\"" >> $(CONFIG_HS)
@echo "cGHC_TOUCHY_PGM = \"$(GHC_TOUCHY_PGM)\"" >> $(CONFIG_HS)
@echo "cGHC_TOUCHY_DIR_REL = \"$(GHC_TOUCHY_DIR_REL)\"" >> $(CONFIG_HS)
@echo "cGHC_UNLIT_PGM = \"$(GHC_UNLIT_PGM)\"" >> $(CONFIG_HS)
@echo "cGHC_UNLIT_DIR_REL = \"$(GHC_UNLIT_DIR_REL)\"" >> $(CONFIG_HS)
@echo "cGHC_MANGLER_PGM = \"$(GHC_MANGLER_PGM)\"" >> $(CONFIG_HS)
@echo "cGHC_MANGLER_DIR_REL = \"$(GHC_MANGLER_DIR_REL)\"" >> $(CONFIG_HS)
@echo "cGHC_SPLIT_PGM = \"$(GHC_SPLIT_PGM)\"" >> $(CONFIG_HS)
@echo "cGHC_SPLIT_DIR_REL = \"$(GHC_SPLIT_DIR_REL)\"" >> $(CONFIG_HS)
@echo "cGHC_SYSMAN_PGM = \"$(GHC_SYSMAN)\"" >> $(CONFIG_HS)
@echo "cGHC_SYSMAN_DIR_REL = \"$(GHC_SYSMAN_DIR)\"" >> $(CONFIG_HS)
@echo "cGHC_CP = \"$(GHC_CP)\"" >> $(CONFIG_HS)
@echo "cGHC_PERL = \"$(GHC_PERL)\"" >> $(CONFIG_HS)
ifeq ($(GhcWithIlx),YES)
......
__interface DataCon 1 0 where
__export DataCon DataCon dataConRepType isExistentialDataCon ;
1 data DataCon ;
1 dataConRepType :: DataCon -> TypeRep.Type ;
1 isExistentialDataCon :: DataCon -> GHCziBase.Bool ;
__interface IdInfo 1 0 where
__export IdInfo IdInfo GlobalIdDetails notGlobalId seqIdInfo vanillaIdInfo ;
1 data IdInfo ;
1 data GlobalIdDetails ;
1 notGlobalId :: GlobalIdDetails ;
1 seqIdInfo :: IdInfo -> GHCziBase.Z0T ;
1 vanillaIdInfo :: IdInfo ;
__interface MkId 1 0 where
__export MkId mkDataConId mkDataConWrapId ;
1 mkDataConId :: Name.Name -> DataCon.DataCon -> Var.Id ;
1 mkDataConWrapId :: DataCon.DataCon -> Var.Id ;
__interface Name 1 0 where
__export Name Name;
1 data Name ;
......@@ -52,7 +52,7 @@ import BasicTypes ( Boxity(..) )
import FastString ( FastString, uniqueOfFS )
import GlaExts
import ST
import PrelBase ( Char(..), chr, ord )
import Char ( chr, ord )
import FastTypes
import Outputable
......
__interface Var 1 0 where
__export Var Var TyVar Id setIdName ;
-- Used by Name
1 type Id = Var;
1 type TyVar = Var;
1 data Var ;
1 setIdName :: Id -> Name.Name -> Id ;
__interface CgBindery 1 0 where
__export CgBindery CgBindings CgIdInfo VolatileLoc StableLoc nukeVolatileBinds;
1 type CgBindings = VarEnv.IdEnv CgIdInfo;
1 data CgIdInfo;
1 data VolatileLoc;
1 data StableLoc;
1 nukeVolatileBinds :: CgBindings -> CgBindings ;
__interface CgExpr 1 0 where
__export CgExpr cgExpr;
1 cgExpr :: StgSyn.StgExpr -> CgMonad.Code ;
__interface CgUsages 1 0 where
__export CgUsages getSpRelOffset;
1 getSpRelOffset :: AbsCSyn.VirtualSpOffset -> CgMonad.FCode AbsCSyn.RegRelative ;
__interface ClosureInfo 1 0 where
__export ClosureInfo ClosureInfo LambdaFormInfo;
1 data LambdaFormInfo;
1 data ClosureInfo;
......@@ -101,8 +101,7 @@ import VarEnv ( emptyTidyEnv )
import BasicTypes ( Fixity, defaultFixity )
import Interpreter ( HValue )
import HscMain ( hscStmt )
import PrelGHC ( unsafeCoerce# )
import GlaExts ( unsafeCoerce# )
import Foreign
import CForeign
import Exception ( Exception, try )
......
__interface CoreSyn 1 0 where
__export CoreSyn CoreExpr ;
-- Needed by Var.lhs
1 type CoreExpr = Expr Var.Var;
1 data Expr b ;
__interface Subst 2 0 where
__export Subst Subst substTyWith ;
1 data Subst;
1 substTyWith :: [Var.TyVar] -> [TypeRep.Type] -> TypeRep.Type -> TypeRep.Type ;
__interface DsExpr 1 0 where
__export DsExpr dsExpr dsLet;
1 dsExpr :: TcHsSyn.TypecheckedHsExpr -> DsMonad.DsM CoreSyn.CoreExpr ;
1 dsLet :: TcHsSyn.TypecheckedHsBinds -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr ;
__interface Match 1 0 where
__export Match match matchExport matchSimply matchSinglePat;
1 match :: [Var.Id] -> [DsUtils.EquationInfo] -> DsMonad.DsM DsUtils.MatchResult ;
1 matchExport :: [Var.Id] -> [DsUtils.EquationInfo] -> DsMonad.DsM DsUtils.MatchResult ;
1 matchSimply :: CoreSyn.CoreExpr -> HsExpr.HsMatchContext Var.Id -> TcHsSyn.TypecheckedPat -> CoreSyn.CoreExpr -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr ;
1 matchSinglePat :: CoreSyn.CoreExpr -> DsMonad.DsMatchContext -> TcHsSyn.TypecheckedPat -> DsUtils.MatchResult -> DsMonad.DsM DsUtils.MatchResult ;
......@@ -15,13 +15,12 @@ import ForeignCall ( CCallConv(..) )
-- DON'T remove apparently unused imports here .. there is ifdeffery
-- below
import Bits ( Bits(..), shiftR, shiftL )
import Foreign ( newArray )
import Word ( Word8, Word32 )
import Addr ( Addr(..), writeWord8OffAddr )
import Foreign ( Ptr(..), mallocBytes )
import IOExts ( trace, unsafePerformIO )
import IO ( hPutStrLn, stderr )
\end{code}
%************************************************************************
......@@ -49,15 +48,6 @@ sizeOfTagW :: PrimRep -> Int
sizeOfTagW pr
| isFollowableRep pr = 0
| otherwise = 1
-- Blast a bunch of bytes into malloc'd memory and return the addr.
sendBytesToMallocville :: [Word8] -> IO Addr
sendBytesToMallocville bytes
= do let n = length bytes
(Ptr a#) <- mallocBytes n
mapM ( \(off,byte) -> writeWord8OffAddr (A# a#) off byte )
(zip [0 ..] bytes)
return (A# a#)
\end{code}
%************************************************************************
......@@ -103,11 +93,11 @@ we don't clear our own (single) arg off the C stack.
-}
mkMarshalCode :: CCallConv
-> (Int, PrimRep) -> Int -> [(Int, PrimRep)]
-> IO Addr
-> IO (Ptr Word8)
mkMarshalCode cconv (r_offW, r_rep) addr_offW arg_offs_n_reps
= let bytes = mkMarshalCode_wrk cconv (r_offW, r_rep)
addr_offW arg_offs_n_reps
in sendBytesToMallocville bytes
in Foreign.newArray bytes
......
......@@ -56,16 +56,15 @@ import ByteCodeFFI ( taggedSizeW, untaggedSizeW, mkMarshalCode, moan64 )
import Linker ( lookupSymbol )
import List ( intersperse, sortBy, zip4 )
import Foreign ( Ptr(..), mallocBytes )
import Addr ( Addr(..), writeCharOffAddr )
import Foreign ( Ptr(..), castPtr, mallocBytes, pokeByteOff, Word8 )
import CTypes ( CInt )
import Exception ( throwDyn )
import PrelBase ( Int(..) )
import PrelGHC ( ByteArray# )
import PrelIOBase ( IO(..) )
import GlaExts ( Int(..), ByteArray# )
import Monad ( when )
import Maybe ( isJust )
import Char ( ord )
\end{code}
%************************************************************************
......@@ -885,7 +884,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l
-> let sym_to_find = _UNPK_ target in
ioToBc (lookupSymbol sym_to_find) `thenBc` \res ->
case res of
Just aa -> case aa of Ptr a# -> returnBc (True, A# a#)
Just aa -> returnBc (True, aa)
Nothing -> ioToBc (linkFail "ByteCodeGen.generateCCall"
sym_to_find)
CasmTarget _
......@@ -935,7 +934,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l
recordMallocBc addr_of_marshaller `thenBc_`
let
-- do the call
do_call = unitOL (CCALL addr_of_marshaller)
do_call = unitOL (CCALL (castPtr addr_of_marshaller))
-- slide and return
wrapup = mkSLIDE r_tsizeW (d_after_r - r_tsizeW - s)
`snocOL` RETURN r_rep
......@@ -1189,7 +1188,7 @@ pushAtom False d p (AnnLit lit)
pushStr s
= let getMallocvilleAddr
= case s of
CharStr s i -> returnBc (A# s)
CharStr s i -> returnBc (Ptr s)
FastString _ l ba ->
-- sigh, a string in the heap is no good to us.
......@@ -1199,12 +1198,12 @@ pushAtom False d p (AnnLit lit)
-- at the same time.
let n = I# l
-- CAREFUL! Chars are 32 bits in ghc 4.09+
in ioToBc (mallocBytes (n+1)) `thenBc` \ (Ptr a#) ->
recordMallocBc (A# a#) `thenBc_`
in ioToBc (mallocBytes (n+1)) `thenBc` \ ptr ->
recordMallocBc ptr `thenBc_`
ioToBc (
do memcpy (Ptr a#) ba (fromIntegral n)
writeCharOffAddr (A# a#) n '\0'
return (A# a#)
do memcpy ptr ba (fromIntegral n)
pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8)
return ptr
)
other -> panic "ByteCodeGen.pushAtom.pushStr"
in
......@@ -1406,7 +1405,7 @@ bind x f = f x
data BcM_State
= BcM_State { bcos :: [ProtoBCO Name], -- accumulates completed BCOs
nextlabel :: Int, -- for generating local labels
malloced :: [Addr] } -- ptrs malloced for current BCO
malloced :: [Ptr ()] } -- ptrs malloced for current BCO
-- Should be free()d when it is GCd
type BcM r = BcM_State -> IO (BcM_State, r)
......@@ -1441,7 +1440,7 @@ mapBc f (x:xs)
mapBc f xs `thenBc` \ rs ->
returnBc (r:rs)
emitBc :: ([Addr] -> ProtoBCO Name) -> BcM ()
emitBc :: ([Ptr ()] -> ProtoBCO Name) -> BcM ()
emitBc bco st
= return (st{bcos = bco (malloced st) : bcos st, malloced=[]}, ())
......@@ -1452,9 +1451,9 @@ newbcoBc st
| otherwise
= return (st, ())
recordMallocBc :: Addr -> BcM ()
recordMallocBc :: Ptr a -> BcM ()
recordMallocBc a st
= return (st{malloced = a : malloced st}, ())
= return (st{malloced = castPtr a : malloced st}, ())
getLabelBc :: BcM Int
getLabelBc st
......
......@@ -19,8 +19,7 @@ import PrimRep ( PrimRep )
import DataCon ( DataCon )
import VarSet ( VarSet )
import PrimOp ( PrimOp )
import Foreign ( Addr )
import Ptr
\end{code}
%************************************************************************
......@@ -37,7 +36,7 @@ data ProtoBCO a
-- what the BCO came from
(Either [AnnAlt Id VarSet]
(AnnExpr Id VarSet))
[Addr] -- malloc'd; free when BCO is GCd
[Ptr ()] -- malloc'd; free when BCO is GCd
nameOfProtoBCO (ProtoBCO nm insns origin malloced) = nm
......@@ -57,7 +56,7 @@ data BCInstr
| PUSH_AS Name PrimRep -- push alts and BCO_ptr_ret_info
-- PrimRep so we know which itbl
-- Pushing literals
| PUSH_UBX (Either Literal Addr)
| PUSH_UBX (Either Literal (Ptr ()))
Int -- push this int/float/double/addr, NO TAG, on the stack
-- Int is # of words to copy from literal pool
-- Eitherness reflects the difficulty of dealing with
......@@ -100,7 +99,7 @@ data BCInstr
| JMP LocalLabel
-- For doing calls to C (via glue code generated by ByteCodeFFI)
| CCALL Addr -- of the glue code
| CCALL (Ptr ()) -- of the glue code
| SWIZZLE Int Int -- to the ptr N words down the stack,
-- add M (interpreted as a signed 16-bit entity)
......
......@@ -31,34 +31,35 @@ import Linker ( lookupSymbol )
import FastString ( FastString(..) )
import ByteCodeInstr ( BCInstr(..), ProtoBCO(..) )
import ByteCodeItbls ( ItblEnv, ItblPtr )
import FiniteMap
import Panic ( GhcException(..) )
import Control.Monad ( when, foldM )
import Control.Monad.ST ( runST )
import Data.Array.IArray ( array )
import Monad ( when, foldM )
import ST ( runST )
import IArray ( array )
import MArray ( castSTUArray,
newInt64Array, writeInt64Array,
newFloatArray, writeFloatArray,
newDoubleArray, writeDoubleArray,
newIntArray, writeIntArray,
newAddrArray, writeAddrArray,
readWordArray )
import GHC.Word ( Word )
import Data.Array.MArray ( MArray, newArray_, readArray, writeArray )
import Data.Array.ST ( castSTUArray )
import Data.Array.Base ( UArray(..) )
import Foreign.Ptr ( Ptr, nullPtr )
import Foreign ( Word16, Ptr(..), free )
import Addr ( Word, Addr(..), nullAddr )
import Weak ( addFinalizer )
import FiniteMap
import System.Mem.Weak ( addFinalizer )
import Data.Int ( Int64 )
import PrelBase ( Int(..) )
import PrelGHC ( BCO#, newBCO#, unsafeCoerce#,
import System.IO ( fixIO )
import Control.Exception ( throwDyn )
import GlaExts ( BCO#, newBCO#, unsafeCoerce#,
ByteArray#, Array#, addrToHValue#, mkApUpd0# )
import IOExts ( fixIO )
import Exception ( throwDyn )
import Panic ( GhcException(..) )
#if __GLASGOW_HASKELL__ >= 503
import GHC.Arr ( Array(..) )
import GHC.IOBase ( IO(..) )
#else
import PrelArr ( Array(..) )
import ArrayBase ( UArray(..) )
import PrelIOBase ( IO(..) )
import Int ( Int64 )
#endif
\end{code}
%************************************************************************
......@@ -206,8 +207,8 @@ assembleBCO (ProtoBCO nm instrs origin malloced)
return ul_bco
where
zonk (A# a#) = do -- putStrLn ("freeing malloc'd block at " ++ show (A# a#))
free (Ptr a#)
zonk ptr = do -- putStrLn ("freeing malloc'd block at " ++ show (A# a#))
free ptr
-- instrs nonptrs ptrs itbls
type AsmState = (SizedSeq Word16, SizedSeq Word,
......@@ -329,7 +330,7 @@ mkBits findLabel st proto_insns
return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
addr (st_i0,st_l0,st_p0,st_I0) a
= do let ws = mkLitA a
= do let ws = mkLitPtr a
st_l1 <- addListToSS st_l0 ws
return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
......@@ -376,19 +377,19 @@ mkBits findLabel st proto_insns
AddrRep -> stg_gc_unbx_r1_info
FloatRep -> stg_gc_f1_info
DoubleRep -> stg_gc_d1_info
VoidRep -> nullAddr
VoidRep -> nullPtr
-- Interpreter.c spots this special case
other -> pprPanic "ByteCodeLink.itoc_itbl" (ppr pk)
foreign label "stg_ctoi_ret_R1p_info" stg_ctoi_ret_R1p_info :: Addr
foreign label "stg_ctoi_ret_R1n_info" stg_ctoi_ret_R1n_info :: Addr
foreign label "stg_ctoi_ret_F1_info" stg_ctoi_ret_F1_info :: Addr
foreign label "stg_ctoi_ret_D1_info" stg_ctoi_ret_D1_info :: Addr
foreign label "stg_ctoi_ret_V_info" stg_ctoi_ret_V_info :: Addr
foreign label "stg_ctoi_ret_R1p_info" stg_ctoi_ret_R1p_info :: Ptr ()
foreign label "stg_ctoi_ret_R1n_info" stg_ctoi_ret_R1n_info :: Ptr ()
foreign label "stg_ctoi_ret_F1_info" stg_ctoi_ret_F1_info :: Ptr ()
foreign label "stg_ctoi_ret_D1_info" stg_ctoi_ret_D1_info :: Ptr ()
foreign label "stg_ctoi_ret_V_info" stg_ctoi_ret_V_info :: Ptr ()
foreign label "stg_gc_unbx_r1_info" stg_gc_unbx_r1_info :: Addr
foreign label "stg_gc_f1_info" stg_gc_f1_info :: Addr
foreign label "stg_gc_d1_info" stg_gc_d1_info :: Addr
foreign label "stg_gc_unbx_r1_info" stg_gc_unbx_r1_info :: Ptr ()
foreign label "stg_gc_f1_info" stg_gc_f1_info :: Ptr ()
foreign label "stg_gc_d1_info" stg_gc_d1_info :: Ptr ()
-- The size in 16-bit entities of an instruction.
instrSize16s :: BCInstr -> Int
......@@ -430,74 +431,73 @@ instrSize16s instr
mkLitI :: Int -> [Word]
mkLitF :: Float -> [Word]
mkLitD :: Double -> [Word]
mkLitA :: Addr -> [Word]
mkLitPtr :: Ptr () -> [Word]
mkLitI64 :: Int64 -> [Word]
mkLitF f
= runST (do
arr <- newFloatArray ((0::Int),0)
writeFloatArray arr 0 f
arr <- newArray_ ((0::Int),0)
writeArray arr 0 f
f_arr <- castSTUArray arr
w0 <- readWordArray f_arr 0
return [w0]
w0 <- readArray f_arr 0
return [w0 :: Word]
)
mkLitD d
| wORD_SIZE == 4
= runST (do
arr <- newDoubleArray ((0::Int),1)
writeDoubleArray arr 0 d
arr <- newArray_ ((0::Int),1)
writeArray arr 0 d
d_arr <- castSTUArray arr
w0 <- readWordArray d_arr 0
w1 <- readWordArray d_arr 1
return [w0,w1]
w0 <- readArray d_arr 0
w1 <- readArray d_arr 1
return [w0 :: Word, w1]
)
| wORD_SIZE == 8
= runST (do
arr <- newDoubleArray ((0::Int),0)
writeDoubleArray arr 0 d
arr <- newArray_ ((0::Int),0)
writeArray arr 0 d
d_arr <- castSTUArray arr
w0 <- readWordArray d_arr 0
return [w0]
w0 <- readArray d_arr 0
return [w0 :: Word]
)
mkLitI64 ii
| wORD_SIZE == 4
= runST (do
arr <- newInt64Array ((0::Int),1)
writeInt64Array arr 0 ii
arr <- newArray_ ((0::Int),1)
writeArray arr 0 ii
d_arr <- castSTUArray arr
w0 <- readWordArray d_arr 0
w1 <- readWordArray d_arr 1
return [w0,w1]
w0 <- readArray d_arr 0
w1 <- readArray d_arr 1
return [w0 :: Word,w1]
)
| wORD_SIZE == 8
= runST (do
arr <- newInt64Array ((0::Int),0)
writeInt64Array arr 0 ii
arr <- newArray_ ((0::Int),0)
writeArray arr 0 ii
d_arr <- castSTUArray arr
w0 <- readWordArray d_arr 0
return [w0]
w0 <- readArray d_arr 0
return [w0 :: Word]
)
mkLitI i
= runST (do
arr <- newIntArray ((0::Int),0)
writeIntArray arr 0 i
arr <- newArray_ ((0::Int),0)
writeArray arr 0 i
i_arr <- castSTUArray arr
w0 <- readWordArray i_arr 0
return [w0]
w0 <- readArray i_arr 0
return [w0 :: Word]
)
mkLitA a
mkLitPtr a
= runST (do
arr <- newAddrArray ((0::Int),0)
writeAddrArray arr 0 a
arr <- newArray_ ((0::Int),0)
writeArray arr 0 a
a_arr <- castSTUArray arr
w0 <- readWordArray a_arr 0
return [w0]
w0 <- readArray a_arr 0
return [w0 :: Word]
)
\end{code}
%************************************************************************
......
{-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-}
-----------------------------------------------------------------------------
-- $Id: InteractiveUI.hs,v 1.112 2002/01/28 13:34:10 simonmar Exp $
-- $Id: InteractiveUI.hs,v 1.113 2002/02/12 15:17:15 simonmar Exp $
--
-- GHC Interactive User Interface
--
......@@ -67,7 +67,8 @@ import IO
import Char
import Monad
import PrelGHC ( unsafeCoerce# )
import GlaExts ( unsafeCoerce# )
import Foreign ( nullPtr )
import CString ( peekCString )
......@@ -271,7 +272,7 @@ interactiveLoop is_tty = do
checkPerms :: String -> IO Bool
checkPerms name =
handle (\_ -> return False) $ do
DriverUtil.handle (\_ -> return False) $ do
#ifdef mingw32_TARGET_OS
doesFileExist name
#else
......
......@@ -15,12 +15,9 @@ module Linker (
addDLL -- :: String -> IO (Ptr CChar)
) where
import PrelByteArr
import PrelPack ( packString )
import Monad ( when )
import CTypes ( CChar )
import Foreign.C
import Foreign ( Ptr, nullPtr )
import Panic ( panic )
import DriverUtil ( prefixUnderscore )
......@@ -32,20 +29,23 @@ import DriverUtil ( prefixUnderscore )
lookupSymbol :: String -> IO (Maybe (Ptr a))
lookupSymbol str_in = do
let str = prefixUnderscore str_in
addr <- c_lookupSymbol (packString str)
if addr == nullPtr
withCString str $ \c_str -> do
addr <- c_lookupSymbol c_str
if addr == nullPtr
then return Nothing
else return (Just addr)
loadObj :: String -> IO ()
loadObj str = do
r <- c_loadObj (packString str)
when (r == 0) (panic "loadObj: failed")
loadObj str =
withCString str $ \c_str -> do
r <- c_loadObj c_str
when (r == 0) (panic "loadObj: failed")
unloadObj :: String -> IO ()
unloadObj str = do
r <- c_unloadObj (packString str)
when (r == 0) (panic "unloadObj: failed")
unloadObj str =
withCString str $ \c_str -> do
r <- c_unloadObj c_str
when (r == 0) (panic "unloadObj: failed")
resolveObjs :: IO Bool
resolveObjs = do
......@@ -54,31 +54,30 @@ resolveObjs = do
addDLL :: String -> String -> IO (Ptr CChar)
addDLL path lib = do
maybe_errmsg <- c_addDLL (packString path) (packString lib)
return maybe_errmsg
foreign import "initLinker" unsafe
initLinker :: IO ()
withCString path $ \c_path -> do
withCString lib $ \c_lib -> do
maybe_errmsg <- c_addDLL c_path c_lib
return maybe_errmsg
-- ---------------------------------------------------------------------------
-- Foreign declaractions to RTS entry points which does the real work;
-- ---------------------------------------------------------------------------
type PackedString = ByteArray Int
foreign import "initLinker" unsafe
initLinker :: IO ()
foreign import "lookupSymbol" unsafe
c_lookupSymbol :: PackedString -> IO (Ptr a)
c_lookupSymbol :: CString -> IO (Ptr a)
foreign import "loadObj" unsafe
c_loadObj :: PackedString -> IO Int
c_loadObj :: CString -> IO Int
foreign import "unloadObj" unsafe
c_unloadObj :: PackedString -> IO Int
c_unloadObj :: CString -> IO Int
foreign import "resolveObjs" unsafe
c_resolveObjs :: IO Int
foreign import "addDLL" unsafe
c_addDLL :: PackedString -> PackedString -> IO (Ptr CChar)
c_addDLL :: CString -> CString -> IO (Ptr CChar)
\end{code}
__interface HsExpr 1 0 where
__export HsExpr HsExpr pprExpr Match GRHSs pprPatBind pprFunBind ;
1 data HsExpr i p ;
1 pprExpr :: __forall [i p] {Outputable.Outputable i, Outputable.Outputable p} => HsExpr.HsExpr i p -> Outputable.SDoc ;
1 data Match a b ;
1 data GRHSs a b ;
1 pprPatBind :: __forall [i p] {Outputable.Outputable i, Outputable.Outputable p} => p -> HsExpr.GRHSs i p -> Outputable.SDoc ;
1 pprFunBind :: __forall [i p] {Outputable.Outputable i, Outputable.Outputable p} => i -> [HsExpr.Match i p] -> Outputable.SDoc ;
-----------------------------------------------------------------------------
-- $Id: DriverState.hs,v 1.67 2002/02/11 08:20:41 chak Exp $
-- $Id: DriverState.hs,v 1.68 2002/02/12 15:17:15 simonmar Exp $
--
-- Settings for the driver
--
......@@ -432,7 +432,7 @@ GLOBAL_VAR(v_HCHeader, "", String)
-- Packages
-- package list is maintained in dependency order
GLOBAL_VAR(v_Packages, ("std":"rts":"gmp":[]), [String])
GLOBAL_VAR(v_Packages, ("haskell98":"base":"rts":[]), [String])
readPackageConf :: String -> IO ()
readPackageConf conf_file = do
......@@ -491,23 +491,23 @@ getPackageLibraries = do
where
-- This is a totally horrible (temporary) hack, for Win32. Problem is