Commit 6c9a37e3 authored by sewardj's avatar sewardj

[project @ 2001-01-15 17:05:46 by sewardj]

More stuff to do with primop support in the interpreter.  Also, track
some changes to the libraries.
parent 7385dd9f
......@@ -14,7 +14,8 @@ module ByteCodeGen ( UnlinkedBCO, UnlinkedBCOExpr, ItblEnv, ClosureEnv, HValue,
import Outputable
import Name ( Name, getName, mkSysLocalName )
import Id ( Id, idType, isDataConId_maybe, mkVanillaId )
import Id ( Id, idType, isDataConId_maybe, mkVanillaId,
isPrimOpId_maybe )
import OrdList ( OrdList, consOL, snocOL, appOL, unitOL,
nilOL, toOL, concatOL, fromOL )
import FiniteMap ( FiniteMap, addListToFM, listToFM,
......@@ -23,6 +24,7 @@ import CoreSyn
import PprCore ( pprCoreExpr )
import Literal ( Literal(..), literalPrimRep )
import PrimRep ( PrimRep(..) )
import PrimOp ( PrimOp(..) )
import CoreFVs ( freeVars )
import Type ( typePrimRep )
import DataCon ( dataConTag, fIRST_TAG, dataConTyCon, dataConWrapId )
......@@ -44,11 +46,10 @@ import ByteCodeLink ( UnlinkedBCO, UnlinkedBCOExpr, assembleBCO,
import List ( intersperse, sortBy )
import Foreign ( Ptr(..), mallocBytes )
import Addr ( addrToInt, writeCharOffAddr )
import Addr ( Addr(..), addrToInt, writeCharOffAddr )
import CTypes ( CInt )
import PrelBase ( Int(..) )
import PrelAddr ( Addr(..) )
import PrelGHC ( ByteArray# )
import IOExts ( unsafePerformIO )
import PrelIOBase ( IO(..) )
......@@ -297,7 +298,7 @@ schemeE d s p (fvs, AnnLet binds b)
-- ToDo: don't build thunks for things with no free variables
buildThunk dd ([], size, id, off)
= PUSH_G (getName id)
= PUSH_G (Left (getName id))
`consOL` unitOL (MKAP (off+size-1) size)
buildThunk dd ((fv:fvs), size, id, off)
= case pushAtom True dd p' (AnnVar fv) of
......@@ -408,7 +409,7 @@ schemeT d s p app
-- Handle case 1
| is_con_call && null args_r_to_l
= (PUSH_G (getName con) `consOL` mkSLIDE 1 (d-s))
= (PUSH_G (Left (getName con)) `consOL` mkSLIDE 1 (d-s))
`snocOL` ENTER
-- Cases 2 and 3
......@@ -570,7 +571,13 @@ mkUnpackCode vars d p
-- 6 stack has valid words 0 .. 5.
pushAtom :: Bool -> Int -> BCEnv -> AnnExpr' Id VarSet -> (BCInstrList, Int)
pushAtom tagged d p (AnnVar v)
pushAtom tagged d p (AnnVar v)
| Just primop <- isPrimOpId_maybe v
= case primop of
CCallOp _ -> panic "pushAtom: byte code generator can't handle CCalls"
other -> (unitOL (PUSH_G (Right primop)), 1)
| otherwise
= let str = "\npushAtom " ++ showSDocDebug (ppr v)
++ " :: " ++ showSDocDebug (pprType (idType v))
++ ", depth = " ++ show d
......@@ -586,7 +593,7 @@ pushAtom tagged d p (AnnVar v)
result
= case lookupBCEnv_maybe p v of
Just d_v -> (toOL (nOfThem nwords (PUSH_L (d-d_v+sz_t-2))), nwords)
Nothing -> ASSERT(sz_t == 1) (unitOL (PUSH_G nm), nwords)
Nothing -> ASSERT(sz_t == 1) (unitOL (PUSH_G (Left nm)), nwords)
nm = case isDataConId_maybe v of
Just c -> getName c
......@@ -629,10 +636,10 @@ pushAtom False d p (AnnLit lit)
let n = I# l
-- CAREFUL! Chars are 32 bits in ghc 4.09+
in unsafePerformIO (
do a@(Ptr addr) <- mallocBytes (n+1)
strncpy a ba (fromIntegral n)
writeCharOffAddr addr n '\0'
return addr
do (Ptr a#) <- mallocBytes (n+1)
strncpy (Ptr a#) ba (fromIntegral n)
writeCharOffAddr (A# a#) n '\0'
return (A# a#)
)
_ -> panic "StgInterp.lit2expr: unhandled string constant type"
......
......@@ -17,6 +17,7 @@ import Literal ( Literal )
import PrimRep ( PrimRep )
import DataCon ( DataCon )
import VarSet ( VarSet )
import PrimOp ( PrimOp )
\end{code}
......@@ -47,7 +48,7 @@ data BCInstr
| PUSH_LL Int Int{-2 offsets-}
| PUSH_LLL Int Int Int{-3 offsets-}
-- Push a ptr
| PUSH_G Name
| PUSH_G (Either Name PrimOp)
-- Push an alt continuation
| PUSH_AS Name PrimRep -- push alts and BCO_ptr_ret_info
-- PrimRep so we know which itbl
......@@ -96,7 +97,9 @@ instance Outputable BCInstr where
ppr (PUSH_L offset) = text "PUSH_L " <+> int offset
ppr (PUSH_LL o1 o2) = text "PUSH_LL " <+> int o1 <+> int o2
ppr (PUSH_LLL o1 o2 o3) = text "PUSH_LLL" <+> int o1 <+> int o2 <+> int o3
ppr (PUSH_G nm) = text "PUSH_G " <+> ppr nm
ppr (PUSH_G (Left nm)) = text "PUSH_G " <+> ppr nm
ppr (PUSH_G (Right op)) = text "PUSH_G " <+> text "PrelPrimopWrappers."
<> ppr op
ppr (PUSH_AS nm pk) = text "PUSH_AS " <+> ppr nm <+> ppr pk
ppr (PUSH_UBX lit nw) = text "PUSH_UBX" <+> parens (int nw) <+> ppr lit
ppr (PUSH_TAG n) = text "PUSH_TAG" <+> int n
......
......@@ -4,7 +4,7 @@
\section[ByteCodeItbls]{Generate infotables for interpreter-made bytecodes}
\begin{code}
module ByteCodeItbls ( ItblEnv, mkITbls ) where
module ByteCodeItbls ( ItblEnv, ItblPtr, mkITbls ) where
#include "HsVersions.h"
......@@ -18,12 +18,11 @@ import ClosureInfo ( mkVirtHeapOffsets )
import FastString ( FastString(..) )
import Foreign ( Storable(..), Word8, Word16, Word32, Ptr(..),
malloc, castPtr, plusPtr )
malloc, castPtr, plusPtr, Addr )
import Addr ( addrToInt )
import Bits ( Bits(..), shiftR )
import PrelBase ( Int(..) )
import PrelAddr ( Addr(..) )
import PrelIOBase ( IO(..) )
\end{code}
......@@ -36,13 +35,9 @@ import PrelIOBase ( IO(..) )
\begin{code}
type ItblEnv = FiniteMap Name (Ptr StgInfoTable)
#if __GLASGOW_HASKELL__ <= 408
type ItblPtr = Addr
#else
type ItblPtr = Ptr StgInfoTable
#endif
type ItblEnv = FiniteMap Name ItblPtr
-- Make info tables for the data decls in this module
mkITbls :: [TyCon] -> IO ItblEnv
......
......@@ -13,11 +13,12 @@ module ByteCodeLink ( UnlinkedBCO, UnlinkedBCOExpr, assembleBCO,
import Outputable
import Name ( Name, getName, nameModule, toRdrName )
import RdrName ( rdrNameOcc, rdrNameModule )
import OccName ( occNameString )
import OccName ( occNameString, occNameUserString )
import FiniteMap ( FiniteMap, addListToFM, filterFM,
addToFM, lookupFM, emptyFM )
import CoreSyn
import Literal ( Literal(..) )
import PrimOp ( PrimOp, primOpOcc )
import PrimRep ( PrimRep(..) )
import Util ( global )
import Constants ( wORD_SIZE )
......@@ -25,7 +26,7 @@ import Module ( ModuleName, moduleName, moduleNameFS )
import Linker ( lookupSymbol )
import FastString ( FastString(..) )
import ByteCodeInstr ( BCInstr(..), ProtoBCO(..) )
import ByteCodeItbls ( ItblEnv )
import ByteCodeItbls ( ItblEnv, ItblPtr )
import Monad ( foldM )
......@@ -36,10 +37,9 @@ import MArray ( castSTUArray,
newIntArray, writeIntArray,
newAddrArray, writeAddrArray )
import Foreign ( Word16, Ptr(..) )
import Addr ( Word )
import Addr ( Word, Addr )
import PrelBase ( Int(..) )
import PrelAddr ( Addr(..) )
import PrelGHC ( BCO#, newBCO#, unsafeCoerce#,
ByteArray#, Array#, addrToHValue#, mkApUpd0# )
import IOExts ( IORef, fixIO, readIORef, writeIORef )
......@@ -77,10 +77,10 @@ linkSomeBCOs ie ce_in ul_bcos
data UnlinkedBCO
= UnlinkedBCO Name
(SizedSeq Word16) -- insns
(SizedSeq Word) -- literals
(SizedSeq Name) -- ptrs
(SizedSeq Name) -- itbl refs
(SizedSeq Word16) -- insns
(SizedSeq Word) -- literals
(SizedSeq (Either Name PrimOp)) -- ptrs
(SizedSeq Name) -- itbl refs
nameOfUnlinkedBCO (UnlinkedBCO nm _ _ _ _) = nm
......@@ -146,7 +146,7 @@ assembleBCO (ProtoBCO nm instrs origin)
do -- pass 2: generate the instruction, ptr and nonptr bits
insns <- return emptySS :: IO (SizedSeq Word16)
lits <- return emptySS :: IO (SizedSeq Word)
ptrs <- return emptySS :: IO (SizedSeq Name)
ptrs <- return emptySS :: IO (SizedSeq (Either Name PrimOp))
itbls <- return emptySS :: IO (SizedSeq Name)
let init_asm_state = (insns,lits,ptrs,itbls)
(final_insns, final_lits, final_ptrs, final_itbls)
......@@ -155,7 +155,8 @@ assembleBCO (ProtoBCO nm instrs origin)
return (UnlinkedBCO nm final_insns final_lits final_ptrs final_itbls)
-- instrs nonptrs ptrs itbls
type AsmState = (SizedSeq Word16, SizedSeq Word, SizedSeq Name, SizedSeq Name)
type AsmState = (SizedSeq Word16, SizedSeq Word,
SizedSeq (Either Name PrimOp), SizedSeq Name)
data SizedSeq a = SizedSeq !Int [a]
emptySS = SizedSeq 0 []
......@@ -184,7 +185,7 @@ mkBits findLabel st proto_insns
PUSH_LLL o1 o2 o3 -> instr4 st i_PUSH_LLL o1 o2 o3
PUSH_G nm -> do (p, st2) <- ptr st nm
instr2 st2 i_PUSH_G p
PUSH_AS nm pk -> do (p, st2) <- ptr st nm
PUSH_AS nm pk -> do (p, st2) <- ptr st (Left nm)
(np, st3) <- ctoi_itbl st2 pk
instr3 st3 i_PUSH_AS p np
PUSH_UBX lit nws -> do (np, st2) <- literal st lit
......@@ -279,9 +280,9 @@ mkBits findLabel st proto_insns
= addr st ret_itbl_addr
where
ret_itbl_addr = case pk of
PtrRep -> stg_ctoi_ret_R1_info
IntRep -> stg_ctoi_ret_R1_info
CharRep -> stg_ctoi_ret_R1_info
PtrRep -> stg_ctoi_ret_R1p_info
IntRep -> stg_ctoi_ret_R1n_info
CharRep -> stg_ctoi_ret_R1n_info
FloatRep -> stg_ctoi_ret_F1_info
DoubleRep -> stg_ctoi_ret_D1_info
_ -> pprPanic "mkBits.ctoi_itbl" (ppr pk)
......@@ -294,9 +295,10 @@ mkBits findLabel st proto_insns
FloatRep -> stg_gc_f1_info
DoubleRep -> stg_gc_d1_info
foreign label "stg_ctoi_ret_R1_info" stg_ctoi_ret_R1_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_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_gc_unbx_r1_info" stg_gc_unbx_r1_info :: Addr
foreign label "stg_gc_f1_info" stg_gc_f1_info :: Addr
......@@ -432,7 +434,7 @@ linkBCO ie ce (UnlinkedBCO nm insnsSS literalsSS ptrsSS itblsSS)
ptrs_parr = case ptrs_arr of Array lo hi parr -> parr
itbls_arr = array (0, n_itbls-1) (indexify linked_itbls)
:: UArray Int Addr
:: UArray Int ItblPtr
itbls_barr = case itbls_arr of UArray lo hi barr -> barr
insns_arr | n_insns > 65535
......@@ -452,9 +454,9 @@ linkBCO ie ce (UnlinkedBCO nm insnsSS literalsSS ptrsSS itblsSS)
BCO bco# <- newBCO insns_barr literals_barr ptrs_parr itbls_barr
return (unsafeCoerce# bco#)
--case mkApUpd0# (unsafeCoerce# bco#) of
-- (# final_bco #) -> return final_bco
-- WAS: return (unsafeCoerce# bco#)
case mkApUpd0# (unsafeCoerce# bco#) of
(# final_bco #) -> return final_bco
data BCO = BCO BCO#
......@@ -464,22 +466,29 @@ newBCO a b c d
= IO (\s -> case newBCO# a b c d s of (# s1, bco #) -> (# s1, BCO bco #))
lookupCE :: ClosureEnv -> Name -> IO HValue
lookupCE ce nm
lookupCE :: ClosureEnv -> Either Name PrimOp -> IO HValue
lookupCE ce (Right primop)
= do m <- lookupSymbol (primopToCLabel primop "closure")
case m of
Just (Ptr addr) -> case addrToHValue# addr of
(# hval #) -> do addCAF hval
return hval
Nothing -> pprPanic "ByteCodeGen.lookupCE(primop)" (ppr primop)
lookupCE ce (Left nm)
= case lookupFM ce nm of
Just aa -> return aa
Nothing
-> do m <- lookupSymbol (nameToCLabel nm "closure")
case m of
Just (A# addr) -> case addrToHValue# addr of
(# hval #) -> do addCAF hval
return hval
Just (Ptr addr) -> case addrToHValue# addr of
(# hval #) -> do addCAF hval
return hval
Nothing -> pprPanic "ByteCodeGen.lookupCE" (ppr nm)
lookupIE :: ItblEnv -> Name -> IO Addr
lookupIE :: ItblEnv -> Name -> IO (Ptr a)
lookupIE ie con_nm
= case lookupFM ie con_nm of
Just (Ptr a) -> return a
Just (Ptr a) -> return (Ptr a)
Nothing
-> do -- try looking up in the object files.
m <- lookupSymbol (nameToCLabel con_nm "con_info")
......@@ -492,13 +501,19 @@ lookupIE ie con_nm
Just addr -> return addr
Nothing -> pprPanic "ByteCodeGen.lookupIE" (ppr con_nm)
-- HACK!!! ToDo: cleaner
-- HACKS!!! ToDo: cleaner
nameToCLabel :: Name -> String{-suffix-} -> String
nameToCLabel n suffix
= _UNPK_(moduleNameFS (rdrNameModule rn))
++ '_':occNameString(rdrNameOcc rn) ++ '_':suffix
where rn = toRdrName n
primopToCLabel :: PrimOp -> String{-suffix-} -> String
primopToCLabel primop suffix
= let str = "PrelPrimopWrappers_" ++ occNameString (primOpOcc primop) ++ '_':suffix
in trace ("primopToCLabel: " ++ str)
str
\end{code}
%************************************************************************
......
......@@ -8,11 +8,11 @@
module Linker (
loadObj, -- :: String -> IO ()
unloadObj, -- :: String -> IO ()
lookupSymbol, -- :: String -> IO (Maybe Addr)
lookupSymbol, -- :: String -> IO (Maybe (Ptr a))
resolveObjs, -- :: IO ()
) where
import Addr
import Foreign ( Ptr, nullPtr )
import PrelByteArr
import PrelPack (packString)
import Panic ( panic )
......@@ -23,7 +23,7 @@ import Panic ( panic )
lookupSymbol str = do
addr <- c_lookupSymbol (packString str)
if addr == nullAddr
if addr == nullPtr
then return Nothing
else return (Just addr)
......@@ -49,7 +49,7 @@ resolveObjs = do
type PackedString = ByteArray Int
foreign import "lookupSymbol" unsafe
c_lookupSymbol :: PackedString -> IO Addr
c_lookupSymbol :: PackedString -> IO (Ptr a)
foreign import "loadObj" unsafe
c_loadObj :: PackedString -> IO Int
......
......@@ -55,6 +55,7 @@ and modify our heap check accordingly.
\begin{code}
-- NB: ordering of clauses somewhere driven by
-- the desire to getting sane patt-matching behavior
primCode [res] IntegerCmpOp args@[sa1,da1, sa2,da2]
= gmpCompare res (sa1,da1, sa2,da2)
......
......@@ -199,9 +199,9 @@ unsafeWriteBuffer s@(StringBuffer a _ _ _) i# ch# =
stringToStringBuffer :: String -> IO StringBuffer
stringToStringBuffer str =
do let sz@(I# sz#) = length str + 1
(Ptr a@(A# a#)) <- mallocBytes sz
fill_in str a
writeCharOffAddr a (sz-1) '\0' -- sentinel
(Ptr a#) <- mallocBytes sz
fill_in str (A# a#)
writeCharOffAddr (A# a#) (sz-1) '\0' -- sentinel
return (StringBuffer a# sz# 0# 0#)
where
fill_in [] _ = return ()
......@@ -210,7 +210,7 @@ stringToStringBuffer str =
fill_in cs (a `plusAddr` 1)
freeStringBuffer :: StringBuffer -> IO ()
freeStringBuffer (StringBuffer a# _ _ _) = Foreign.free (Ptr (A# a#))
freeStringBuffer (StringBuffer a# _ _ _) = Foreign.free (Ptr a#)
#endif
\end{code}
......
......@@ -66,10 +66,16 @@ SRC_MKDEPENDHS_OPTS += -I$(GHC_INCLUDE_DIR)
#-----------------------------------------------------------------------------
# Rules
PrelPrimopWrappers.hs: ../../compiler/prelude/primops.txt
rm -f PrelPrimopWrappers.hs
../../utils/genprimopcode/genprimopcode --make-haskell-wrappers \
< ../../compiler/prelude/primops.txt > PrelPrimopWrappers.hs
PrelGHC.$(way_)hi : PrelGHC.hi-boot
cp $< $@
boot :: PrelGHC.hi $(foreach way, $(WAYS), PrelGHC.$(way)_hi)
boot :: PrelPrimopWrappers.hs PrelGHC.hi $(foreach way, $(WAYS), PrelGHC.$(way)_hi)
all :: PrelPrimopWrappers.hs
DLL_DESCRIPTION="GHC-compiled Haskell Prelude"
......@@ -83,7 +89,7 @@ ifeq "$(DLLized)" "YES"
all :: PrelMain.dll_o
endif
CLEAN_FILES += PrelGHC.hi $(foreach way, $(WAYS), PrelGHC.$(way)_hi)
CLEAN_FILES += PrelPrimopWrappers.hs PrelGHC.hi $(foreach way, $(WAYS), PrelGHC.$(way)_hi)
#
# If we're building the unregisterised way, it may well be for Hugs.
......
......@@ -75,8 +75,8 @@ main = getArgs >>= \args ->
"--primop-list"
-> putStr (gen_primop_list p_o_specs)
"--c-bytecode-enum"
-> putStr (gen_enum_decl p_o_specs)
"--make-haskell-wrappers"
-> putStr (gen_wrappers p_o_specs)
)
......@@ -93,14 +93,37 @@ known_args
"--primop-primop-info",
"--primop-tag",
"--primop-list",
"--c-bytecode-enum"
"--make-haskell-wrappers"
]
------------------------------------------------------------------
-- Code generators -----------------------------------------------
------------------------------------------------------------------
gen_wrappers (Info defaults pos)
= "module PrelPrimopWrappers where\n"
++ "import qualified PrelGHC\n"
++ unlines (map f (filter (not.dodgy) pos))
where
f spec = let args = map (\n -> "a" ++ show n) [1 .. arity (ty spec)]
src_name = wrap (name spec)
in "{-# NOINLINE " ++ src_name ++ " #-}\n" ++
src_name ++ " " ++ unwords args
++ " = (PrelGHC." ++ name spec ++ ") " ++ unwords args
wrap nm | isLower (head nm) = nm
| otherwise = "(" ++ nm ++ ")"
dodgy spec
= name spec `elem`
[-- C code generator can't handle these
"seq#",
"tagToEnum#",
-- not interested in parallel support
"par#", "parGlobal#", "parLocal#", "parAt#",
"parAtAbs#", "parAtRel#", "parAtForNow#"
]
gen_primop_list (Info defaults pos)
= unlines (
[ " [" ++ cons (head pos) ]
......@@ -116,11 +139,6 @@ gen_primop_tag (Info defaults pos)
f i n = "tagOf_PrimOp " ++ cons i
++ " = _ILIT(" ++ show n ++ ") :: FastInt"
gen_enum_decl (Info defaults pos)
= let conss = map cons pos
in "enum PrimOp {\n " ++ head conss ++ "\n"
++ unlines (map (" , "++) (tail conss)) ++ "};\n"
gen_data_decl (Info defaults pos)
= let conss = map cons pos
in "data PrimOp\n = " ++ head conss ++ "\n"
......@@ -256,6 +274,8 @@ tvsIn (TyApp tc tys) = concatMap tvsIn tys
tvsIn (TyVar tv) = [tv]
tvsIn (TyUTup tys) = concatMap tvsIn tys
arity = length . fst . flatTys
------------------------------------------------------------------
-- Abstract syntax -----------------------------------------------
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment