From 13386b66f4fcc1fbf2f7df13e8687510e857c848 Mon Sep 17 00:00:00 2001 From: sof Date: Thu, 25 Oct 2001 05:07:32 +0000 Subject: [PATCH] [project @ 2001-10-25 05:07:32 by sof] follow-on from prev. commit; more tidyups --- ghc/compiler/codeGen/CgTailCall.lhs | 6 +++--- ghc/compiler/ghci/ByteCodeGen.lhs | 5 +++-- ghc/compiler/ghci/ByteCodeItbls.lhs | 5 +++-- ghc/compiler/ghci/ByteCodeLink.lhs | 23 ++++++++++++----------- ghc/compiler/ghci/Linker.lhs | 31 ++++++++++++++++++++----------- ghc/compiler/main/MkIface.lhs | 4 ++-- 6 files changed, 43 insertions(+), 31 deletions(-) diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs index acfc3ae..8dfd5f4 100644 --- a/ghc/compiler/codeGen/CgTailCall.lhs +++ b/ghc/compiler/codeGen/CgTailCall.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgTailCall.lhs,v 1.30 2001/06/25 14:36:04 simonpj Exp $ +% $Id: CgTailCall.lhs,v 1.31 2001/10/25 05:07:32 sof Exp $ % %******************************************************** %* * @@ -52,7 +52,7 @@ import StgSyn ( StgArg ) import Type ( isUnLiftedType ) import TyCon ( TyCon ) import PrimOp ( PrimOp ) -import Util ( zipWithEqual ) +import Util ( zipWithEqual, splitAtList ) import ListSetOps ( assocMaybe ) import Outputable import Panic ( panic, assertPanic ) @@ -396,7 +396,7 @@ doTailCall arg_amodes arg_regs finish_code arity pending_assts = getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) -> let - (reg_arg_amodes, stk_arg_amodes) = splitAt (length arg_regs) arg_amodes + (reg_arg_amodes, stk_arg_amodes) = splitAtList arg_regs arg_amodes -- We get some stk_arg_amodes if (a) no regs, or -- (b) args beyond arity diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index 2bee279..5a375c4 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -33,7 +33,8 @@ import TyCon ( TyCon(..), tyConFamilySize, isDataTyCon, tyConDataCons, isFunTyCon, isUnboxedTupleTyCon ) import Class ( Class, classTyCon ) import Type ( Type, repType, splitRepFunTys ) -import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem ) +import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem, + isSingleton, lengthIs ) import Var ( isTyVar ) import VarSet ( VarSet, varSetElems ) import PrimRep ( isFollowableRep ) @@ -539,7 +540,7 @@ schemeT d s p app isVoidRepAtom (_, AnnNote n e) = isVoidRepAtom e in is_con_call && isUnboxedTupleCon con && ( (args_r_to_l `lengthIs` 2 && isVoidRepAtom (last (args_r_to_l))) - || (isSingleton args_r_to_l) ) + || (isSingleton args_r_to_l) ) = --trace (if isSingleton args_r_to_l -- then "schemeT: unboxed singleton" diff --git a/ghc/compiler/ghci/ByteCodeItbls.lhs b/ghc/compiler/ghci/ByteCodeItbls.lhs index ae1f35b..6caac2f 100644 --- a/ghc/compiler/ghci/ByteCodeItbls.lhs +++ b/ghc/compiler/ghci/ByteCodeItbls.lhs @@ -19,6 +19,7 @@ import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons ) import Constants ( mIN_SIZE_NonUpdHeapObject ) import ClosureInfo ( mkVirtHeapOffsets ) import FastString ( FastString(..) ) +import Util ( lengthIs, listLengthCmp ) import Foreign ( Storable(..), Word8, Word16, Word32, Word64, Ptr(..), malloc, castPtr, plusPtr, Addr ) @@ -55,7 +56,7 @@ mkITbl :: TyCon -> IO ItblEnv mkITbl tc | not (isDataTyCon tc) = return emptyFM - | n == length dcs -- paranoia; this is an assertion. + | dcs `lengthIs` n -- paranoia; this is an assertion. = make_constr_itbls dcs where dcs = tyConDataCons tc @@ -67,7 +68,7 @@ cONSTR = 1 -- as defined in ghc/includes/ClosureTypes.h -- Assumes constructors are numbered from zero, not one make_constr_itbls :: [DataCon] -> IO ItblEnv make_constr_itbls cons - | length cons <= 8 + | listLengthCmp cons 8 /= GT -- <= 8 elements in the list = do is <- mapM mk_vecret_itbl (zip cons [0..]) return (listToFM is) | otherwise diff --git a/ghc/compiler/ghci/ByteCodeLink.lhs b/ghc/compiler/ghci/ByteCodeLink.lhs index 1e9e10f..435c9cc 100644 --- a/ghc/compiler/ghci/ByteCodeLink.lhs +++ b/ghc/compiler/ghci/ByteCodeLink.lhs @@ -606,17 +606,18 @@ lookupIE ie con_nm linkFail :: String -> String -> IO a linkFail who what - = throwDyn (ProgramError ( - "\nDuring interactive linking, GHCi couldn't find the following symbol:\n" ++ - " " ++ what ++ "\n" ++ - "This may be due to you not asking GHCi to load extra object files,\n" ++ - "archives or DLLs needed by your current session. Restart GHCi, specifying\n" ++ - "the missing library using the -L/path/to/object/dir and -lmissinglibname\n" ++ - "flags, or simply by naming the relevant files on the GHCi command line.\n" ++ - "Alternatively, this link failure might indicate a bug in GHCi.\n" ++ - "If you suspect the latter, please send a bug report to:\n" ++ - " glasgow-haskell-bugs@haskell.org\n" - )) + = throwDyn (ProgramError $ + unlines [ "" + , "During interactive linking, GHCi couldn't find the following symbol:" + , ' ' : ' ' : what + , "This may be due to you not asking GHCi to load extra object files," + , "archives or DLLs needed by your current session. Restart GHCi, specifying" + , "the missing library using the -L/path/to/object/dir and -lmissinglibname" + , "flags, or simply by naming the relevant files on the GHCi command line." + , "Alternatively, this link failure might indicate a bug in GHCi." + , "If you suspect the latter, please send a bug report to:" + , " glasgow-haskell-bugs@haskell.org" + ]) -- HACKS!!! ToDo: cleaner nameToCLabel :: Name -> String{-suffix-} -> String diff --git a/ghc/compiler/ghci/Linker.lhs b/ghc/compiler/ghci/Linker.lhs index 238d009..475f707 100644 --- a/ghc/compiler/ghci/Linker.lhs +++ b/ghc/compiler/ghci/Linker.lhs @@ -15,10 +15,13 @@ module Linker ( addDLL -- :: String -> IO (Ptr CChar) ) where +import PrelByteArr +import PrelPack ( packString ) + +import Monad ( when ) + import CTypes ( CChar ) import Foreign ( Ptr, nullPtr ) -import PrelByteArr -import PrelPack (packString) import Panic ( panic ) import DriverUtil ( prefixUnderscore ) @@ -26,6 +29,7 @@ import DriverUtil ( prefixUnderscore ) -- RTS Linker Interface -- --------------------------------------------------------------------------- +lookupSymbol :: String -> IO (Maybe (Ptr a)) lookupSymbol str_in = do let str = prefixUnderscore str_in addr <- c_lookupSymbol (packString str) @@ -33,26 +37,34 @@ lookupSymbol str_in = do then return Nothing else return (Just addr) +loadObj :: String -> IO () loadObj str = do r <- c_loadObj (packString str) - if (r == 0) - then panic "loadObj: failed" - else return () + when (r == 0) (panic "loadObj: failed") +unloadObj :: String -> IO () unloadObj str = do r <- c_unloadObj (packString str) - if (r == 0) - then panic "unloadObj: failed" - else return () + when (r == 0) (panic "unloadObj: failed") +resolveObjs :: IO Bool resolveObjs = do r <- c_resolveObjs return (r /= 0) -- returns True <=> success +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 () + +-- --------------------------------------------------------------------------- +-- Foreign declaractions to RTS entry points which does the real work; +-- --------------------------------------------------------------------------- + type PackedString = ByteArray Int foreign import "lookupSymbol" unsafe @@ -67,9 +79,6 @@ foreign import "unloadObj" unsafe foreign import "resolveObjs" unsafe c_resolveObjs :: IO Int -foreign import "initLinker" unsafe - initLinker :: IO () - foreign import "addDLL" unsafe c_addDLL :: PackedString -> PackedString -> IO (Ptr CChar) \end{code} diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 0514ce7..450b984 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -59,7 +59,7 @@ import TcType ( tcSplitSigmaTy, tidyTopType, deNoteType, namesOfDFunHead ) import SrcLoc ( noSrcLoc ) import Outputable import Module ( ModuleName ) -import Util ( sortLt ) +import Util ( sortLt, dropList ) import ErrUtils ( dumpIfSet_dyn ) import Monad ( when ) @@ -238,7 +238,7 @@ ifaceTyThing (ATyCon tycon) = ty_decl where (tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con field_labels = dataConFieldLabels data_con - strict_marks = drop (length ex_theta) (dataConStrictMarks data_con) + strict_marks = dropList ex_theta (dataConStrictMarks data_con) -- The 'drop' is because dataConStrictMarks -- includes the existential dictionaries details | null field_labels -- 1.7.10.4