WARNING! Access to this system is limited to authorised users only.
Unauthorised users may be subject to prosecution.
Unauthorised access to this system is a criminal offence under Australian law (Federal Crimes Act 1914 Part VIA)
It is a criminal offence to:
(1) Obtain access to data without authority. -Penalty 2 years imprisonment.
(2) Damage, delete, alter or insert data without authority. -Penalty 10 years imprisonment.
User activity is monitored and recorded. Anyone using this system expressly consents to such monitoring and recording.

To protect your data, the CISO officer has suggested users to enable 2FA as soon as possible.
Currently 2.4% of users enabled 2FA.

Commit bfb1f903 authored by Pavel Zakopaylo's avatar Pavel Zakopaylo
Browse files

Fixed misc. issues in StgLet code

* Fixed issue where bound vars were passed twice
* Fixed issue where enumeration tycons were processed twice
* Fixed mu type errors
parent 9bb9cc35
......@@ -372,7 +372,7 @@ paramsFor :: BasicBlockName
-> [(VarName, TypedefName)]
paramsFor block mapping = fmap pairUp (M.toAscList mapping)
where
pairUp (id, (_, varType, _)) = (block `dot` tail (stringify id), varType)
pairUp (i, (_, varType, _)) = (block `dot` tail (stringify i), varType)
-- | Assign the result of a Mu 'Expression' to a 'VarName'.
......@@ -535,6 +535,10 @@ string name bytes = do
topLevels %= (|> ByteArray name' bytes)
return name'
string' :: GlobalCellName -> B.ByteString -> Mu ()
string' name bytes = do
definitions %= (|> GlobalCell name muStringRef)
topLevels %= (|> ByteArray name bytes)
-- | Emit a type definition.
typedef :: TypedefName -> Type -> Mu ()
......@@ -579,6 +583,8 @@ stringify a
stableName = zString . zEncodeFS . fsLit . nameStableString
uniquePart = show . getUnique
toVarName :: HasName a => a -> VarName
toVarName = VarName . toName
closureNameOf :: (Uniquable a, NamedThing a) => a -> GlobalCellName
closureNameOf n = GlobalCellName $ Name $ stringify n <> "_closure"
......@@ -601,6 +607,10 @@ entryNameOf' n = VarName $ Name $ stringify n <> "_entry"
signatureNameOf :: FunctionName -> SignatureName
signatureNameOf n = case n of
FunctionName (Name n) -> SignatureName $ Name (n <> "_sig")
funTypeNameOf :: FunctionName -> TypedefName
funTypeNameOf n = case n of
FunctionName (Name n) -> TypedefName $ Name (n <> "_funty")
dataConEntry :: (Uniquable a, NamedThing a) => a -> FunctionName
......
......@@ -74,6 +74,7 @@ stgToMu dflags modData (tyCons, bindings) =
bundleMu dflags modName $ do
loadTypes
mapM_ codegenTop bindings
traceM "Finished translating bindings"
mapM_ codegenType tyCons
where
modName = traceShowId $ mmName modData
......@@ -97,9 +98,9 @@ codegenTop binding = do
-- | Generate code for a type.
codegenType :: TyCon -> Mu ()
codegenType tycon = do
when (isEnumerationTyCon tycon) $ codegenEnumerations tycon
mapM_ codegenDataCon (tyConDataCons tycon)
codegenType tycon = if isEnumerationTyCon tycon
then codegenEnumerations tycon
else mapM_ codegenDataCon (tyConDataCons tycon)
-- | Generate the static reference code for the entries of enumerated data
......@@ -111,6 +112,7 @@ codegenEnumerations _tycon = mapM_ codegenDataCon $ tyConDataCons _tycon
-- | Generate the static closures for data constructor fields.
codegenDataCon :: DataCon -> Mu ()
codegenDataCon dcon = do
traceShowM ("Inside DataCon: ", dataConEntry dcon)
-- store the name of this constructor
cName <- string (dataConName dcon) (pack $ tail $ stringify $ dataConName dcon)
......@@ -143,7 +145,7 @@ codegenDataCon dcon = do
codegenTop' :: DynFlags -> GHC.Id -> StgRhs -> ((GHC.Id, (GlobalCellName, LambdaFormInfo)), Mu ())
codegenTop' dflags name rhs = case rhs of
codegenTop' dflags name rhs = traceShow ("Compiling ", name) $ case rhs of
StgRhsCon _cc con args -> ((name, (staticInfoNameOf name, mkConLFInfo con)), code)
where
......@@ -168,7 +170,7 @@ codegenTop' dflags name rhs = case rhs of
when (not $ null nonglobfrees) $
error "panic: top-level closures should only have top-level free variables"
entry <- closureBody name args [] body
(entry, _) <- closureBody name args [] body
emitInfo (conInfoNameOf name) (infoTable' args entry)
closure name (conInfoNameOf name) (payload' args)
......@@ -181,7 +183,7 @@ codegenTop' dflags name rhs = case rhs of
payload' args = case args of
[] -> [NullPointer] -- thunk, needs spot for indirection
l -> [] --function
l -> [] -- function
primordialEntry = case rhs of
StgRhsCon _ con _ -> dataConEntry' con
......@@ -221,6 +223,7 @@ literal arg = case arg of
Lit.MachStr str -> do
uid <- nextMuUnique
let strName = GlobalCellName $ Name ("@_str" ++ uid)
string' strName str
return $ TaggedPointer strName 0
Lit.MachNullAddr -> do
return NullPointer
......@@ -231,11 +234,12 @@ literal arg = case arg of
-- | Generate the closure code corresponding to an 'StgExpr'.
closureBody :: GHC.Id -> [GHC.Id] -> [GHC.Id] -> StgExpr -> Mu FunctionName
closureBody :: GHC.Id -> [GHC.Id] -> [GHC.Id] -> StgExpr -> Mu (FunctionName, TypedefName)
closureBody name _ _ _ | traceShow ("closurebody", (entryNameOf name)) False = undefined
closureBody name args fvars body = do
args' <- mapM idMuType args
funcsig funcSig (muClosureIref : args') [muClosureIref]
typedef funcTy $ FuncRef funcSig
let muNames = map (dot entry . tail . stringify) args
let namedArgs = zip muNames args'
......@@ -254,7 +258,7 @@ closureBody name args fvars body = do
boundNames <- sortedIDNames
return $ Branch1 $ DestinationClause sequel boundNames) `capturing` argBind
return funcName
return (funcName, funcTy)
where
......@@ -262,6 +266,7 @@ closureBody name args fvars body = do
this = funcName `dot` "entry.this"
funcName = entryNameOf name
funcSig = signatureNameOf funcName
funcTy = funTypeNameOf funcName
-- | Bind some free variables from a closure to actual Mu values.
......@@ -299,21 +304,21 @@ withFVBindings name this fvars isThunk code = do
-- | Create and populate a closure's info table at runtime
mkInfo :: BasicBlockName -- ^ Outer basic block, for naming purposes
-> RunTimeInfoTable -- ^ Static parameters
-> ExpWriter VarName
-> ExpWriter (VarName, TypedefName, TypedefName)
mkInfo block table = do
-- generate table
infoRef <- assign block $ New infoMuType Nothing
infoIref <- assign block $ GetIRef infoMuType infoRef
simpleInfoIref <- if infoMuType == infoTable then
simpleInfoIref <- if infoMuType /= infoTable then
assign block $ GetFieldIRef False infoMuType 0 infoIref
else return infoIref
infoType' <- upValue (IntCtor $ fromIntegral $ fromEnum infoType) i32
-- fill basic fields
entryFieldRef <- assign block $ GetFieldIRef False infoTableIref (fromEnum EntryField) simpleInfoIref
entryFieldRef <- assign block $ GetFieldIRef False infoTable (fromEnum EntryField) simpleInfoIref
emit $ Store False Nothing muClosureFunction entryFieldRef (funToVar entry) Nothing
typeFieldRef <- assign block $ GetFieldIRef False infoTableIref (fromEnum TypeField) simpleInfoIref
typeFieldRef <- assign block $ GetFieldIRef False infoTable (fromEnum TypeField) simpleInfoIref
emit $ Store False Nothing i32 typeFieldRef infoType' Nothing
-- fill type-specific fields
......@@ -333,16 +338,16 @@ mkInfo block table = do
RTThunkInfoTable _ -> do
return ()
return infoIref
return (infoIref, infoMuType, infoMuRefType)
where
infoType :: ClosureType -- help the type inferencer out a bit..
(infoMuType, entry, infoType) = case table of
RTSimpleInfoTable e i -> (infoTable, e, i)
RTConsInfoTable (RTSimpleInfoTable e i) _ _ -> (consInfoTable, e, i)
RTFunInfoTable (RTSimpleInfoTable e i) _ _ -> (funInfoTable, e, i)
RTThunkInfoTable (RTSimpleInfoTable e i) -> (thunkInfoTable, e, i)
(infoMuType, infoMuRefType, entry, infoType) = case table of
RTSimpleInfoTable e i -> (infoTable, infoTableIref, e, i)
RTConsInfoTable (RTSimpleInfoTable e i) _ _ -> (consInfoTable, consInfoTableIref, e, i)
RTFunInfoTable (RTSimpleInfoTable e i) _ _ -> (funInfoTable, funInfoTableIref, e, i)
RTThunkInfoTable (RTSimpleInfoTable e i) -> (thunkInfoTable, thunkInfoTableIref, e, i)
funToVar :: FunctionName -> VarName
funToVar (FunctionName n) = VarName n
......@@ -383,7 +388,7 @@ mkClosure block table fvars isThunk = do
clos' <- assign block $ GetIRef closTypeName clos
-- write info table to closure
headerRef <- assign block $ GetFieldIRef False closTypeName 0 clos'
headerRef <- assign block $ GetFieldIRef False closTypeName 0 clos'
infoRefRef <- assign block $ GetFieldIRef False muClosure (fromEnum ClosInfoTable) headerRef
emit $ Store False Nothing infoTableIref infoRefRef table Nothing
......@@ -440,9 +445,6 @@ populateClosurePayload block (clos, closTypeName, closTypeRefName) fvars isThunk
fst3 :: (a, b, c) -> a
fst3 (x, _, _) = x
toVarName :: GlobalCellName -> VarName
toVarName (GlobalCellName n) = VarName n
instance Show Var.Var where
show = show . entryNameOf
......@@ -507,7 +509,7 @@ expression name topExpr = do
oldBinds <- getLocalBinds
let allocBlockName = entry `dot` ("alloc" ++ uq)
bb <- basicBlock allocBlockName boundNames $ case binds of
bb <- basicBlock allocBlockName [] $ case binds of
StgNonRec bindId rhs -> do
(bind, code) <- codegenLetBind allocBlockName bindId rhs
code
......@@ -535,9 +537,6 @@ expression name topExpr = do
showBind (StgNonRec bindId _) = show $ closureNameOf bindId
showBind (StgRec binds) = show $ fmap (closureNameOf . fst) binds
toVarName :: FunctionName -> VarName
toVarName fn = case fn of
FunctionName n -> VarName n
-- FIXME: As is obvious, this is just doing the same thing as StgLet.
-- This kills tail-call performance.
......@@ -567,9 +566,11 @@ codegenLetBind block bindId rhs = case rhs of
StgRhsClosure _cc _bindinfo nonglobfrees updateFlag _srt args body -> do
dflags <- liftExpr $ gets _dflags
let lf_info = mkClosureLFInfo dflags bindId NotTopLevel (nonVoidIds nonglobfrees) updateFlag args
allocClosureBody <- liftExpr $ closureBody bindId args nonglobfrees body
(allocClosureBody'', funTy) <- liftExpr $ closureBody bindId args nonglobfrees body
allocClosureBody' <- assign block $ ConvertOperation REFCAST funTy muClosureFunction $ toVarName allocClosureBody''
let allocClosureBody = toFunName allocClosureBody'
info' <- (case args of
info'' <- (case args of
[] -> do
return $ RTThunkInfoTable (RTSimpleInfoTable allocClosureBody Thunk)
-- XXX: funType not used
......@@ -577,7 +578,8 @@ codegenLetBind block bindId rhs = case rhs of
arity <- upValue (IntCtor $ fromIntegral $ length args) i32
funType <- upValue (IntCtor 0) i32
return $ RTFunInfoTable (RTSimpleInfoTable allocClosureBody Function) funType arity)
info <- mkInfo block info'
(info', _, infoRefTy) <- mkInfo block info''
info <- assign block $ ConvertOperation REFCAST infoRefTy infoTableIref info'
closDef@(clos, closType, closRefType) <- mkClosure block info (Left nonglobfrees) (null args)
clos' <- assign block $ ConvertOperation REFCAST closRefType muClosureIref clos
......@@ -586,16 +588,16 @@ codegenLetBind block bindId rhs = case rhs of
StgRhsCon _cc con args -> do
let lf_info = mkConLFInfo con
info <- assign block $ ConvertOperation REFCAST consInfoTableIref infoTableIref (toVarName $ staticInfoNameOf con)
closDef@(clos, closType, closRefType) <- mkClosure block (toVarName $ staticInfoNameOf con) (Right args) False
clos' <- assign block $ ConvertOperation REFCAST closRefType muClosureIref clos
return ((bindId, (clos', muClosureIref, lf_info)), populateClosurePayload block closDef (Right args) False)
where
toVarName :: GlobalCellName -> VarName
toVarName gcn = case gcn of
GlobalCellName n -> VarName n
where
toFunName :: VarName -> FunctionName
toFunName (VarName n) = FunctionName n
-- FIXME: 'muEmitReturn' and 'muEmitEnter' need to send the bound params to the new
......@@ -609,7 +611,7 @@ muEmitReturn entry vals = do
boundNames <- sortedParams
let bbName = entry `dot` ("returnBlock" ++ uq)
bb <- basicBlock bbName boundNames $ case sequel of
bb <- basicBlock bbName [] $ case sequel of
MuReturn -> return $ Return vals
MuBranchTo targetBB -> return $ Branch1 $ DestinationClause targetBB vals
......@@ -625,7 +627,7 @@ muEmitEnter entry (val, muType) = do
boundNames <- sortedParams
let bbName = entry `dot` ("entryBlock" ++ uq)
bb <- basicBlock bbName boundNames $ do
bb <- basicBlock bbName [] $ do
-- TODO: move this gorp to another function?
headerRef <- assign bbName $ ConvertOperation REFCAST muType muClosure val
infoRefRef <- assign bbName $ GetFieldIRef False muClosure (fromEnum ClosInfoTable) headerRef
......@@ -656,9 +658,9 @@ muEmitEnter entry (val, muType) = do
placeholderBlocks :: FunctionName -> Blocks BasicBlockName
placeholderBlocks n = do
emitBB $ BasicBlock bbName [(param, muClosureIref)] Nothing
[]
(Comminst CiUvmThreadExit [] [] [] [] Nothing Nothing)
bb <- basicBlock bbName [] $
return $ Comminst CiUvmThreadExit [] [] [] [] Nothing Nothing
emitBB bb
return bbName
where
bbName = n `dot` "placeholder"
......
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