From b3e4cb91c4386c4d1456b896da1abb964f2124a6 Mon Sep 17 00:00:00 2001 From: simonmar Date: Fri, 6 Sep 2002 14:35:45 +0000 Subject: [PATCH] [project @ 2002-09-06 14:35:42 by simonmar] Finally separate the compiler from hslibs. Mainly import wibbles, and use the new POSIX library when bootstrapping. --- ghc/compiler/HsVersions.h | 4 ++++ ghc/compiler/Makefile | 11 +++++++++-- ghc/compiler/absCSyn/PprAbsC.lhs | 2 +- ghc/compiler/deSugar/DsCCall.lhs | 31 ++++++------------------------- ghc/compiler/ghci/InteractiveUI.hs | 6 +++--- ghc/compiler/main/Main.hs | 7 ++++++- ghc/compiler/main/ParsePkgConf.y | 6 +++--- ghc/compiler/main/SysTools.lhs | 9 ++++++++- ghc/compiler/nativeGen/PprMach.lhs | 2 +- ghc/compiler/parser/Parser.y | 7 ++++--- ghc/compiler/utils/Digraph.lhs | 19 ++++++++++++++++++- ghc/compiler/utils/FastString.lhs | 2 +- ghc/compiler/utils/PrimPacked.lhs | 2 +- 13 files changed, 65 insertions(+), 43 deletions(-) diff --git a/ghc/compiler/HsVersions.h b/ghc/compiler/HsVersions.h index 62c9c07..0560611 100644 --- a/ghc/compiler/HsVersions.h +++ b/ghc/compiler/HsVersions.h @@ -23,6 +23,8 @@ you will screw up the layout where they are used in case expressions! #define TRACE Debug.Trace #define DATA_IOREF Data.IORef #define FIX_IO System.IO +#define MONAD_ST Control.Monad.ST +#define ST_ARRAY Data.Array.ST #else @@ -37,6 +39,8 @@ you will screw up the layout where they are used in case expressions! #define TRACE IOExts #define DATA_IOREF IOExts #define FIX_IO IOExts +#define MONAD_ST ST +#define ST_ARRAY ST #endif diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index cc46148..531ec2a 100644 --- a/ghc/compiler/Makefile +++ b/ghc/compiler/Makefile @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Makefile,v 1.220 2002/08/29 15:44:12 simonmar Exp $ +# $Id: Makefile,v 1.221 2002/09/06 14:35:43 simonmar Exp $ TOP = .. @@ -134,7 +134,10 @@ endif # Only include GHCi if we're bootstrapping with at least version 411 ifeq "$(GhcWithInterpreter)" "YES" ifeq "$(bootstrapped)" "YES" -SRC_HC_OPTS += -DGHCI +SRC_HC_OPTS += -DGHCI -package readline +ifneq "$(TARGETPLATFORM)" "i386-unknown-mingw32" +SRC_HC_OPTS += -package unix +endif ALL_DIRS += ghci endif endif @@ -184,11 +187,15 @@ SRC_HC_OPTS += \ # which needs it). SRC_MKDEPENDHS_OPTS += -I$(GHC_INCLUDE_DIR) +# When bootstrapped, we don't make use of *any* packages +# (except possibly readline if GHCi is enabled, see above) +ifneq "$(bootstrapped)" "YES" ifneq "$(mingw32_HOST_OS)" "1" SRC_HC_OPTS += -package concurrent -package posix -package util else SRC_HC_OPTS += -package concurrent -package util endif +endif SRC_CC_OPTS += -Iparser -I. -I$(TOP)/includes -O SRC_HC_OPTS += -recomp $(GhcHcOpts) diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index fff3006..58cf18f 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -66,7 +66,7 @@ import Data.Array.ST #endif import GLAEXTS -import ST +import MONAD_ST infixr 9 `thenTE` \end{code} diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs index 19bddd3..23743bd 100644 --- a/ghc/compiler/deSugar/DsCCall.lhs +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -220,11 +220,6 @@ boxResult :: [Id] -> Type -> DsM (Type, CoreExpr -> CoreExpr) -- the result type will be -- State# RealWorld -> (# State# RealWorld #) --- Here is where we arrange that ForeignPtrs which are passed to a 'safe' --- foreign import don't get finalized until the call returns. For each --- argument of type ForeignObj# we arrange to touch# the argument after --- the call. The arg_ids passed in are the Ids passed to the actual ccall. - boxResult arg_ids result_ty = case tcSplitTyConApp_maybe result_ty of -- This split absolutely has to be a tcSplit, because we must @@ -267,13 +262,11 @@ boxResult arg_ids result_ty where mk_alt return_result (Nothing, wrap_result) = -- The ccall returns () - let - rhs_fun state_id = return_result (Var state_id) - (wrap_result (panic "boxResult")) - in newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id -> - mkTouches arg_ids state_id rhs_fun `thenDs` \ the_rhs -> let + the_rhs = return_result (Var state_id) + (wrap_result (panic "boxResult")) + ccall_res_ty = mkTyConApp unboxedSingletonTyCon [realWorldStatePrimTy] the_alt = (DataAlt unboxedSingletonDataCon, [state_id], the_rhs) in @@ -282,28 +275,16 @@ boxResult arg_ids result_ty mk_alt return_result (Just prim_res_ty, wrap_result) = -- The ccall returns a non-() value newSysLocalDs prim_res_ty `thenDs` \ result_id -> - let - rhs_fun state_id = return_result (Var state_id) - (wrap_result (Var result_id)) - in newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id -> - mkTouches arg_ids state_id rhs_fun `thenDs` \ the_rhs -> let + the_rhs = return_result (Var state_id) + (wrap_result (Var result_id)) + ccall_res_ty = mkTyConApp unboxedPairTyCon [realWorldStatePrimTy, prim_res_ty] the_alt = (DataAlt unboxedPairDataCon, [state_id, result_id], the_rhs) in returnDs (ccall_res_ty, the_alt) -touchzh = mkPrimOpId TouchOp - -mkTouches [] s cont = returnDs (cont s) -mkTouches (v:vs) s cont - | not (idType v `eqType` foreignObjPrimTy) = mkTouches vs s cont - | otherwise = newSysLocalDs realWorldStatePrimTy `thenDs` \s' -> - mkTouches vs s' cont `thenDs` \ rest -> - returnDs (Case (mkApps (Var touchzh) [Type foreignObjPrimTy, - Var v, Var s]) s' - [(DEFAULT, [], rest)]) resultWrapper :: Type -> (Maybe Type, -- Type of the expected result, if any diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 4825368..14208e1 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,6 +1,6 @@ {-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-} ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.132 2002/08/29 15:44:14 simonmar Exp $ +-- $Id: InteractiveUI.hs,v 1.133 2002/09/06 14:35:44 simonmar Exp $ -- -- GHC Interactive User Interface -- @@ -49,11 +49,11 @@ import Panic ( GhcException(..), showGhcException ) import Config #ifndef mingw32_TARGET_OS -import Posix +import System.Posix #endif #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS -import Readline +import System.Console.Readline as Readline #endif --import SystemExts diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs index 5687bfb..8c55d44 100644 --- a/ghc/compiler/main/Main.hs +++ b/ghc/compiler/main/Main.hs @@ -1,7 +1,7 @@ {-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-} ----------------------------------------------------------------------------- --- $Id: Main.hs,v 1.109 2002/08/29 15:44:15 simonmar Exp $ +-- $Id: Main.hs,v 1.110 2002/09/06 14:35:44 simonmar Exp $ -- -- GHC Driver program -- @@ -69,7 +69,12 @@ import EXCEPTION ( raiseInThread ) import EXCEPTION ( throwTo ) # endif +#if __GLASGOW_HASKELL__ > 504 +import System.Posix.Signals +#else import Posix ( Handler(Catch), installHandler, sigINT, sigQUIT ) +#endif + import DYNAMIC ( toDyn ) #endif diff --git a/ghc/compiler/main/ParsePkgConf.y b/ghc/compiler/main/ParsePkgConf.y index 71fe194..e916111 100644 --- a/ghc/compiler/main/ParsePkgConf.y +++ b/ghc/compiler/main/ParsePkgConf.y @@ -1,6 +1,8 @@ { module ParsePkgConf( loadPackageConfig ) where +#include "HsVersions.h" + import Packages ( PackageConfig(..), defaultPackageConfig ) import Lex import FastString @@ -8,9 +10,7 @@ import StringBuffer import SrcLoc import Outputable import Panic ( GhcException(..) ) -import Exception ( throwDyn ) - -#include "HsVersions.h" +import EXCEPTION ( throwDyn ) } diff --git a/ghc/compiler/main/SysTools.lhs b/ghc/compiler/main/SysTools.lhs index 8b2ab35..bca9a7e 100644 --- a/ghc/compiler/main/SysTools.lhs +++ b/ghc/compiler/main/SysTools.lhs @@ -94,13 +94,17 @@ import Directory ( doesFileExist, removeFile ) #endif #ifndef mingw32_HOST_OS +#if __GLASGOW_HASKELL__ > 504 +import qualified GHC.Posix +#else import qualified Posix +#endif #else import List ( isPrefixOf ) import Util ( dropList ) import MarshalArray import Foreign -import Foreign.C.String +import CString #endif #ifdef mingw32_HOST_OS @@ -856,6 +860,9 @@ getExecDir :: IO (Maybe String) = do return Nothing #ifdef mingw32_HOST_OS foreign import "_getpid" unsafe getProcessID :: IO Int -- relies on Int == Int32 on Windows +#elif __GLASGOW_HASKELL__ > 504 +getProcessID :: IO Int +getProcessID = GHC.Posix.c_getpid >>= return . fromIntegral #else getProcessID :: IO Int getProcessID = Posix.getProcessID diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs index 6f75890..564a799 100644 --- a/ghc/compiler/nativeGen/PprMach.lhs +++ b/ghc/compiler/nativeGen/PprMach.lhs @@ -32,7 +32,7 @@ import Data.Word ( Word8 ) import MutableArray #endif -import ST +import MONAD_ST import Char ( chr, ord ) import Maybe ( isJust ) diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index ea8f6f5..f128af2 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- -*-haskell-*- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.100 2002/06/07 07:16:05 chak Exp $ +$Id: Parser.y,v 1.101 2002/09/06 14:35:44 simonmar Exp $ Haskell grammar. @@ -11,6 +11,8 @@ Author(s): Simon Marlow, Sven Panne 1997, 1998, 1999 { module Parser ( parseModule, parseStmt, parseIdentifier, parseIface ) where +#include "HsVersions.h" + import HsSyn import HsTypes ( mkHsTupCon ) @@ -35,13 +37,12 @@ import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..), NewOrData(..), StrictnessMark(..), Activation(..) ) import Panic -import GlaExts +import GLAEXTS import CStrings ( CLabelString ) import FastString import Maybes ( orElse ) import Outputable -#include "HsVersions.h" } {- diff --git a/ghc/compiler/utils/Digraph.lhs b/ghc/compiler/utils/Digraph.lhs index 3fb9dd4..ea3b61c 100644 --- a/ghc/compiler/utils/Digraph.lhs +++ b/ghc/compiler/utils/Digraph.lhs @@ -37,13 +37,19 @@ module Digraph( import Util ( sortLt ) -- Extensions -import ST +import MONAD_ST -- std interfaces import Maybe import Array import List import Outputable + +#if __GLASGOW_HASKELL__ >= 504 +import Data.Array.ST hiding ( indices, bounds ) +#else +import ST +#endif \end{code} @@ -233,6 +239,17 @@ draw (Node x ts) = grp this (space (length this)) (stLoop ts) %************************************************************************ \begin{code} +#if __GLASGOW_HASKELL__ >= 504 +newSTArray :: Ix i => (i,i) -> e -> ST s (STArray s i e) +newSTArray = newArray + +readSTArray :: Ix i => STArray s i e -> i -> ST s e +readSTArray = readArray + +writeSTArray :: Ix i => STArray s i e -> i -> e -> ST s () +writeSTArray = writeArray +#endif + type Set s = STArray s Vertex Bool mkEmpty :: Bounds -> ST s (Set s) diff --git a/ghc/compiler/utils/FastString.lhs b/ghc/compiler/utils/FastString.lhs index d29ce9f..ea36957 100644 --- a/ghc/compiler/utils/FastString.lhs +++ b/ghc/compiler/utils/FastString.lhs @@ -55,7 +55,7 @@ import GHC.IOBase ( IO(..) ) import PrimPacked import GLAEXTS import UNSAFE_IO ( unsafePerformIO ) -import ST ( stToIO ) +import MONAD_ST ( stToIO ) import DATA_IOREF ( IORef, newIORef, readIORef, writeIORef ) #if __GLASGOW_HASKELL__ < 503 diff --git a/ghc/compiler/utils/PrimPacked.lhs b/ghc/compiler/utils/PrimPacked.lhs index a0ee810..aa582e7 100644 --- a/ghc/compiler/utils/PrimPacked.lhs +++ b/ghc/compiler/utils/PrimPacked.lhs @@ -33,7 +33,7 @@ module PrimPacked ( import GLAEXTS import UNSAFE_IO ( unsafePerformIO ) -import ST +import MONAD_ST import Foreign #if __GLASGOW_HASKELL__ < 503 -- 1.7.10.4