import Cmm
import PprCmm
-import CmmUtils ( mkIntCLit, mkLblExpr )
+import CmmUtils ( mkIntCLit )
import CmmLex
import CLabel
import MachOp
-import SMRep ( tablesNextToCode, fixedHdrSize, CgRep(..) )
+import SMRep ( fixedHdrSize, CgRep(..) )
import Lexer
import ForeignCall ( CCallConv(..) )
import Unique
import UniqFM
import SrcLoc
-import CmdLineOpts ( DynFlags, DynFlag(..), opt_SccProfilingOn )
+import DynFlags ( DynFlags, DynFlag(..) )
+import Packages ( HomeModules )
+import StaticFlags ( opt_SccProfilingOn )
import ErrUtils ( printError, dumpIfSet_dyn, showPass )
import StringBuffer ( hGetStringBuffer )
import FastString
import Outputable
import Monad ( when )
+import Data.Char ( ord )
#include "HsVersions.h"
}
return [CmmStaticLit (getLit e)] }
| type ';' { return [CmmUninitialised
(machRepByteWidth $1)] }
- | 'bits8' '[' ']' STRING ';' { return [CmmString $4] }
+ | 'bits8' '[' ']' STRING ';' { return [mkString $4] }
| 'bits8' '[' INT ']' ';' { return [CmmUninitialised
(fromIntegral $3)] }
| typenot8 '[' INT ']' ';' { return [CmmUninitialised
{ do lits <- sequence $4;
return $ map CmmStaticLit $
mkStaticClosure (mkRtsInfoLabelFS $3)
- dontCareCCS (map getLit lits) [] [] }
+ dontCareCCS (map getLit lits) [] [] [] }
-- arrays of closures required for the CHARLIKE & INTLIKE arrays
lits :: { [ExtFCode CmmExpr] }
| 'INFO_TABLE_RET' '(' NAME ',' INT ',' INT ',' INT maybe_vec ')'
{ retInfo $3 $5 $7 $9 $10 }
-maybe_vec :: { [CLabel] }
+maybe_vec :: { [CmmLit] }
: {- empty -} { [] }
- | ',' NAME maybe_vec { mkRtsCodeLabelFS $2 : $3 }
+ | ',' NAME maybe_vec { CmmLabel (mkRtsCodeLabelFS $2) : $3 }
body :: { ExtCode }
: {- empty -} { return () }
-- This is not C-- syntax. What to do?
vols :: { Maybe [GlobalReg] }
: {- empty -} { Nothing }
+ | '[' ']' { Just [] }
| '[' globals ']' { Just $2 }
globals :: { [GlobalReg] }
section "bss" = UninitialisedData
section s = OtherSection s
+mkString :: String -> CmmStatic
+mkString s = CmmString (map (fromIntegral.ord) s)
+
-- mkMachOp infers the type of the MachOp from the type of its first
-- argument. We assume that this is correct: for MachOps that don't have
-- symmetrical args (e.g. shift ops), the first arg determines the type of
( FSLIT("INFO_TYPE"), \ [x] -> infoTableClosureType x ),
( FSLIT("INFO_PTRS"), \ [x] -> infoTablePtrs x ),
( FSLIT("INFO_NPTRS"), \ [x] -> infoTableNonPtrs x ),
- ( FSLIT("RET_VEC"), \ [info, conZ] -> CmmLoad (vectorSlot info conZ) wordRep )
+ ( FSLIT("RET_VEC"), \ [info, conZ] -> retVec info conZ )
]
-- we understand a subset of C-- primitives:
retInfo name size live_bits cl_type vector = do
let liveness = smallLiveness (fromIntegral size) (fromIntegral live_bits)
- (info1,info2) = mkRetInfoTable liveness NoC_SRT
+ info_lbl = mkRtsRetInfoLabelFS name
+ (info1,info2) = mkRetInfoTable info_lbl liveness NoC_SRT
(fromIntegral cl_type) vector
- return (mkRtsRetInfoLabelFS name, info1, info2)
+ return (info_lbl, info1, info2)
stdInfo name ptrs nptrs srt_bitmap cl_type desc_str ty_str =
basicInfo name (packHalfWordsCLit ptrs nptrs)
staticClosure :: FastString -> FastString -> [CmmLit] -> ExtCode
staticClosure cl_label info payload
= code $ emitDataLits (mkRtsDataLabelFS cl_label) lits
- where lits = mkStaticClosure (mkRtsInfoLabelFS info) dontCareCCS payload [] []
+ where lits = mkStaticClosure (mkRtsInfoLabelFS info) dontCareCCS payload [] [] []
foreignCall
:: String
initEnv :: Env
initEnv = listToUFM [
( FSLIT("SIZEOF_StgHeader"),
- CmmLit (CmmInt (fromIntegral (fixedHdrSize * wORD_SIZE)) wordRep) )
+ CmmLit (CmmInt (fromIntegral (fixedHdrSize * wORD_SIZE)) wordRep) ),
+ ( FSLIT("SIZEOF_StgInfoTable"),
+ CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordRep) )
]
-parseCmmFile :: DynFlags -> FilePath -> IO (Maybe Cmm)
-parseCmmFile dflags filename = do
+parseCmmFile :: DynFlags -> HomeModules -> FilePath -> IO (Maybe Cmm)
+parseCmmFile dflags hmods filename = do
showPass dflags "ParseCmm"
buf <- hGetStringBuffer filename
let
case unP cmmParse init_state of
PFailed span err -> do printError span err; return Nothing
POk _ code -> do
- cmm <- initC no_module (getCmm (unEC code initEnv [] >> return ()))
+ cmm <- initC dflags hmods no_module (getCmm (unEC code initEnv [] >> return ()))
dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms [cmm])
return (Just cmm)
where
no_module = panic "parseCmmFile: no module"
-
}