From: simonpj Date: Thu, 1 Aug 2002 14:34:42 +0000 (+0000) Subject: [project @ 2002-08-01 14:34:42 by simonpj] X-Git-Tag: Approx_11550_changesets_converted~1781 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=5b868c3b6b977b560fc9568e3d2919eedb09b254;p=ghc-hetmet.git [project @ 2002-08-01 14:34:42 by simonpj] Make the byte-code generator understand about unboxed tuple returns. The previous code was just wrong. This code is better but it is still not *right*, I fear. Don't merge till we sort this out. --- diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index bde65b5..345a81b 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -26,7 +26,7 @@ import Literal ( Literal(..), literalPrimRep ) import PrimRep ( PrimRep(..) ) import PrimOp ( PrimOp(..) ) import CoreFVs ( freeVars ) -import Type ( typePrimRep, splitTyConApp_maybe, isTyVarTy ) +import Type ( typePrimRep, isUnLiftedType, splitTyConApp_maybe, isTyVarTy ) import DataCon ( dataConTag, fIRST_TAG, dataConTyCon, dataConWrapId, isUnboxedTupleCon ) import TyCon ( TyCon(..), tyConFamilySize, isDataTyCon, tyConDataCons, @@ -115,7 +115,7 @@ coreExprToBCOs dflags expr -- create a totally bogus name for the top-level BCO; this -- should be harmless, since it's never used for anything - let invented_id = mkSysLocal FSLIT("Expr-Top-Level") + let invented_id = mkSysLocal FSLIT("ExprTopLevel") (mkPseudoUnique3 0) (panic "invented_id's type") let invented_name = idName invented_id @@ -288,18 +288,20 @@ schemeE d s p e@(fvs, AnnApp f a) = schemeT d s p (fvs, AnnApp f a) schemeE d s p e@(fvs, AnnVar v) - | isFollowableRep v_rep - = -- Ptr-ish thing; push it in the normal way + | not (isUnLiftedType v_type) + = -- Lifted-type thing; push it in the normal way schemeT d s p (fvs, AnnVar v) | otherwise - = -- returning an unboxed value. Heave it on the stack, SLIDE, and RETURN. + = -- Returning an unlifted value. + -- Heave it on the stack, SLIDE, and RETURN. pushAtom True d p (AnnVar v) `thenBc` \ (push, szw) -> returnBc (push -- value onto stack `appOL` mkSLIDE szw (d-s) -- clear to sequel `snocOL` RETURN v_rep) -- go where - v_rep = typePrimRep (idType v) + v_type = idType v + v_rep = typePrimRep v_type schemeE d s p (fvs, AnnLit literal) = pushAtom True d p (AnnLit literal) `thenBc` \ (push, szw) -> @@ -484,25 +486,30 @@ schemeE d s p (fvs_case, AnnCase (fvs_scrut, scrut) bndr -{- Convert case .... of (# VoidRep'd-thing, a #) -> ... - as - case .... of a -> ... - Use a as the name of the binder too. - - Also case .... of (# a #) -> ... - to - case .... of a -> ... --} schemeE d s p (fvs, AnnCase scrut bndr [(DataAlt dc, [bind1, bind2], rhs)]) | isUnboxedTupleCon dc && VoidRep == typePrimRep (idType bind1) + -- Convert + -- case .... of x { (# VoidRep'd-thing, a #) -> ... } + -- to + -- case .... of a { DEFAULT -> ... } + -- becuse the return convention for both are identical. + -- + -- Note that it does not matter losing the void-rep thing from the + -- envt (it won't be bound now) because we never look such things up. + = --trace "automagic mashing of case alts (# VoidRep, a #)" ( - schemeE d s p (fvs, AnnCase scrut bind2 [(DEFAULT, [bind2], rhs)]) + schemeE d s p (fvs, AnnCase scrut bind2 [(DEFAULT, [], rhs)]) + -- Note: --) schemeE d s p (fvs, AnnCase scrut bndr [(DataAlt dc, [bind1], rhs)]) | isUnboxedTupleCon dc + -- Similarly, convert + -- case .... of x { (# a #) -> ... } + -- to + -- case .... of a { DEFAULT -> ... } = --trace "automagic mashing of case alts (# a #)" ( - schemeE d s p (fvs, AnnCase scrut bind1 [(DEFAULT, [bind1], rhs)]) + schemeE d s p (fvs, AnnCase scrut bind1 [(DEFAULT, [], rhs)]) --) schemeE d s p (fvs, AnnCase scrut bndr alts) @@ -522,13 +529,13 @@ schemeE d s p (fvs, AnnCase scrut bndr alts) isAlgCase | scrut_primrep == PtrRep = True - | scrut_primrep `elem` - [CharRep, AddrRep, WordRep, IntRep, FloatRep, DoubleRep, - VoidRep, Int8Rep, Int16Rep, Int32Rep, Int64Rep, - Word8Rep, Word16Rep, Word32Rep, Word64Rep] - = False - | otherwise - = pprPanic "ByteCodeGen.schemeE" (ppr scrut_primrep) + | otherwise + = WARN( scrut_primrep `elem` bad_reps, + text "Dire warning: strange rep in primitive case:" <+> ppr bndr ) + -- We don't expect to see any of these + False + where + bad_reps = [CodePtrRep, DataPtrRep, RetRep, CostCentreRep] -- given an alt, return a discr and code for it. codeAlt alt@(discr, binds_f, rhs) diff --git a/ghc/compiler/ghci/ByteCodeLink.lhs b/ghc/compiler/ghci/ByteCodeLink.lhs index c9e2ee5..eac4de0 100644 --- a/ghc/compiler/ghci/ByteCodeLink.lhs +++ b/ghc/compiler/ghci/ByteCodeLink.lhs @@ -24,7 +24,7 @@ import FiniteMap ( FiniteMap, addListToFM, filterFM, import CoreSyn import Literal ( Literal(..) ) import PrimOp ( PrimOp, primOpOcc ) -import PrimRep ( PrimRep(..) ) +import PrimRep ( PrimRep(..), isFollowableRep ) import Constants ( wORD_SIZE ) import Module ( ModuleName, moduleName, moduleNameFS ) import Linker ( lookupSymbol ) @@ -369,7 +369,6 @@ mkBits findLabel st proto_insns where ret_itbl_addr = case pk of - PtrRep -> stg_ctoi_ret_R1p_info WordRep -> stg_ctoi_ret_R1n_info IntRep -> stg_ctoi_ret_R1n_info AddrRep -> stg_ctoi_ret_R1n_info @@ -377,7 +376,11 @@ mkBits findLabel st proto_insns FloatRep -> stg_ctoi_ret_F1_info DoubleRep -> stg_ctoi_ret_D1_info VoidRep -> stg_ctoi_ret_V_info - other -> pprPanic "ByteCodeLink.ctoi_itbl" (ppr pk) + other | isFollowableRep pk -> stg_ctoi_ret_R1p_info + -- Includes ArrayRep, ByteArrayRep, as well as + -- the obvious PtrRep + | otherwise + -> pprPanic "ByteCodeLink.ctoi_itbl" (ppr pk) itoc_itbl st pk = addr st ret_itbl_addr @@ -390,9 +393,10 @@ mkBits findLabel st proto_insns AddrRep -> stg_gc_unbx_r1_info FloatRep -> stg_gc_f1_info DoubleRep -> stg_gc_d1_info - VoidRep -> nullPtr - -- Interpreter.c spots this special case - other -> pprPanic "ByteCodeLink.itoc_itbl" (ppr pk) + VoidRep -> nullPtr -- Interpreter.c spots this special case + other | isFollowableRep pk -> stg_gc_unpt_r1_info + | otherwise + -> pprPanic "ByteCodeLink.itoc_itbl" (ppr pk) 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 () @@ -401,6 +405,7 @@ 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 :: Ptr () +foreign label "stg_gc_unpt_r1_info" stg_gc_unpt_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 ()