Permalink
Browse files

Merge 1630:1632 from trunk on OneBigGrin-branch.

(Last merge was 1610:1630)
  • Loading branch information...
1 parent 3b3b201 commit 70b02bce1a20b2d29f2cde532d0e8d769b577899 jleeuwes committed Jun 5, 2009
View
@@ -97,7 +97,7 @@ DATA CMetaBind
DATA CMetaVal
| Val
%%[[9
- | Dict mbPos: {Maybe Int}
+ | Dict mbPos: {Maybe [Int]}
| DictClass names: {[Maybe HsName]}
| DictInstance names: {[Maybe HsName]}
%%]]
View
@@ -119,7 +119,7 @@ pCMetaBind
pCMetaVal :: CParser CMetaVal
pCMetaVal
= CMetaVal_Val <$ pKeyTk "VAL"
- <|> CMetaVal_Dict <$ pKeyTk "DICT" <*> ( Just <$ pOCURLY <*> (pInt <|> ((\_ n -> 0-n) <$> pMINUS <*> pInt)) <* pCCURLY
+ <|> CMetaVal_Dict <$ pKeyTk "DICT" <*> ( Just <$ pOCURLY <*> pListSep pCOMMA (pInt <|> ((\_ n -> 0-n) <$> pMINUS <*> pInt)) <* pCCURLY
<|> pSucceed Nothing
)
<|> CMetaVal_DictClass <$ pKeyTk "DICTCLASS" <* pOCURLY <*> pListSep pCOMMA pMbDollNm <* pCCURLY
View
@@ -73,6 +73,10 @@ ppCBindL = ppAssocL . map (\(CBind_Bind n m v) -> (n,v >|< ppOptCMetas m))
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%[(8 codegen) hs
+
+ppSignedInt :: Int -> PP_Doc
+ppSignedInt n = " " >#< show n
+
ppDef :: (PP a, PP b) => a -> b -> PP_Doc
ppDef n v = n >-< indent 2 v
@@ -245,7 +249,7 @@ SEM CMetaBind
SEM CMetaVal
| Val loc . pp = pp "VAL"
%%[[9
- | Dict loc . pp = pp "DICT" >|< maybe "" (\n->"{ "++show n++"}") @mbPos
+ | Dict loc . pp = pp "DICT" >|< maybe (pp "") (\ns -> ppCurlysCommasWith ppSignedInt ns) @mbPos
| DictClass loc . pp = pp "DICTCLASS" >|< ppCurlysCommasWith ppMbCNm @names
| DictInstance loc . pp = pp "DICTINSTANCE" >|< ppCurlysCommasWith ppMbCNm @names
%%]]
View
@@ -546,12 +546,18 @@ SEM CBind
where tyState = Ty_Con $ ehbnRealWorld (ehcOptBuiltinNames @lhs.opts)
[nmState,nmRes,nmIgnoreRes] = take 3 (hsnUniqSupply @lUniq2)
wrapRes = mkRes . dealWithUnitRes
- where mkRes r = GrExpr_Seq r (GrPatLam_Var nmRes) (GrExpr_Unit $ mkGrRecNode $ map GrVal_Var [nmState,nmRes])
+ where mkRes r = GrExpr_Seq (unit2store r) (GrPatLam_Var nmRes) (GrExpr_Unit $ mkGrRecNode $ map GrVal_Var [nmState,nmRes])
dealWithUnitRes
= case tyMbRecExts iores of
Just (_,[]) -> \r -> GrExpr_Seq r (GrPatLam_Var nmIgnoreRes) (GrExpr_Unit $ mkGrRecNode [])
_ -> id
_ -> (@resTy,[],[],id)
+
+{
+unit2store :: GrExpr -> GrExpr
+unit2store (GrExpr_Seq e p (GrExpr_Unit x)) = GrExpr_Seq e p (GrExpr_Store x)
+unit2store e = error $ "unit2store applied to non-unit " ++ show e
+}
%%]
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -832,7 +838,7 @@ SEM CExpr
%%[(8 codegen grin)
ATTR CExpr [ | | grLamArgL: {[HsName]} grLamBody: GrExpr ]
-ATTR CExpr [ | | lamArgDicts: {[Int]} ]
+ATTR CExpr [ | | lamArgDicts: {[[Int]]} ]
SEM CExpr
| Lam lhs . grLamArgL = @arg : @body.grLamArgL
@@ -865,8 +871,8 @@ SEM CExpr
%%[(8 codegen grin)
-ATTR AllMetaVal [ lamArgDicts: {[Int]} | | ]
-ATTR AllMetaVal [ | | grBindAnn : {GrBindAnn} argDicts: {[Int]} ]
+ATTR AllMetaVal [ lamArgDicts: {[[Int]]} | | ]
+ATTR AllMetaVal [ | | grBindAnn : {GrBindAnn} argDicts: {[[Int]]} ]
SEM CMetaVal
| Val lhs . grBindAnn = if null @lhs.lamArgDicts
@@ -79,7 +79,7 @@ SEM CExpr
ATTR AllMetaVal [ | | lifteeSet : {Set.Set HsName} ]
ATTR AllMetaVal [ | | isDict : {Bool}
isDictInst : {Bool}
- mbPos : {Maybe Int} ]
+ mbPos : {Maybe [Int]} ]
SEM CMetaVal
| Val lhs.lifteeSet = Set.empty
@@ -137,7 +137,7 @@ SEM CBind
| Bind lhs.liftedBinds = if @nm `Set.member` @lhs.lifteeSet
then let dependencies = @lhs.findDependencies @expr.fvS
locals = filter isValBind dependencies
- args = (maybe id (\nm->((nm,-1):)) @lhs.selfDictNm)
+ args = (maybe id (\nm->((nm,[]):)) @lhs.selfDictNm)
[ (nm, p)
| (CBind_Bind nm bm _) <- dependencies
, let mbp = mbMetaPos $ cmetasVal bm
@@ -171,7 +171,7 @@ SEM CExpr
)
SEM CExpr
- | Lam body.selfDictNm = maybe Nothing (\p->if p== -1 then Just @arg else Nothing) @argMeta.mbPos
+ | Lam body.selfDictNm = maybe Nothing (\p->if p==[] then Just @arg else Nothing) @argMeta.mbPos
SEM CModule
@@ -223,12 +223,12 @@ isValBind :: CBind -> Bool
isValBind (CBind_Bind _ (_,CMetaVal_Val) _) = True
isValBind _ = False
-mbMetaPos :: CMetaVal -> Maybe Int
+mbMetaPos :: CMetaVal -> Maybe [Int]
mbMetaPos (CMetaVal_Dict mbp) = mbp
mbMetaPos _ = Nothing
-mkLam :: (HsName,Int) -> CExpr -> CExpr
+mkLam :: (HsName,[Int]) -> CExpr -> CExpr
mkLam (nm,p) body = CExpr_Lam nm (CMetaVal_Dict (Just p)) body
mkLet :: CBind -> CExpr -> CExpr
View
@@ -918,13 +918,16 @@ SEM Decl
( @chrScopeDeclsBindL
++ @chrAssumeDeclsInstBindL
)
+
+ defaultCHRBindingsAnnotated = annotateBindings @dictSelfNm defaultCHRBindings
+
dict5 = mkCExprAppMeta (CExpr_Tup @dictTag)
(zip memberNewVars defaultMetas)
- dict6 = mkCExprLetRec ([bind5] ++ defaultNewBindings ++ defaultCHRBindings) rsltVar
+ dict6 = mkCExprLetRec ([bind5] ++ defaultNewBindings ++ defaultCHRBindingsAnnotated) rsltVar
bind5 = mkCBind1Meta rsltNm (CMetaVal_Dict Nothing) dict5
-
- in ( mkCExprLam1Meta selfNm (CMetaVal_Dict (Just (-1))) dict6
+
+ in ( mkCExprLam1Meta selfNm (CMetaVal_Dict (Just [])) dict6
, CMetaVal_DictClass defaultMbNewNames
)
@@ -948,6 +951,23 @@ getBindLeftAndRightVar _ = error "getBindLeftAndRightVar: not a bind"
+annBind (CBind_Bind x _ e) mba = CBind_Bind x (CMetaBind_Plain, CMetaVal_Dict mba) e
+
+annotateBindings selfnm bs = zipWith annBind bs (map mbFindValueVar xs)
+ where ps = map (\(CBind_Bind x _ e)->(x,e)) bs
+ mp = Map.fromList ps
+ xs = map fst ps
+ mbFindValueVar x | x==selfnm = Just []
+ | otherwise = maybe Nothing mbFindValueExpr (Map.lookup x mp)
+ mbFindValueExpr (CExpr_Var y) = mbFindValueVar y
+ mbFindValueExpr (CExpr_Let _ [CBind_Bind _ _ (CExpr_Var v)] c) = let mba = mbFindValueVar v
+ in maybe (trace ("ToCore: annotateBindings: name not found:"++show v) Nothing) (\a->Just (a ++ [findPlace c])) mba
+ mbFindValueExpr e = Nothing
+ findPlace (CExpr_Case _ [CAlt_Alt (CPat_Con _ _ _ zs) (CExpr_Var v)] _) = findPosition v 0 zs
+ findPosition v n [] = error ("ToCore: annotateBindings: position not found: " ++ show v)
+ findPosition v n (CPatBind_Bind x _ _ _:zs) | v==x = n
+ | otherwise = findPosition v (n+1) zs
+
%%]
@@ -172,9 +172,9 @@ doCompileGrin input opts
; specialize "-123-3"
; specialize "-123-4"
; specialize "-123-5"
- --; specialize "-123-6"
- --; specialize "-123-7"
- --; specialize "-123-8"
+ ; specialize "-123-6"
+ -- ; specialize "-123-7"
+ -- ; specialize "-123-8"
; transformCode (dropUnreachableBindings False)
"DropUnreachableBindings" ; caWriteGrin "-126-reachable"
View
@@ -122,15 +122,16 @@ emptyGrTagAnn = mkGrTagAnn 0 0
-- They contain "Just" the name of the instance implementation, or "Nothing" if it relies on the default implementation.
-- Overloaded: binds a function with dictionary parameters
-- The numbers specify which dictionaries are needed:
--- -1 if the dictionary of which the function is a member is needed
--- 0 if the first superclass is needed (for example, the Eq dictionary for a member of Ord)
--- 1 if the second superclass is needed, etc.
+-- [-1] if the dictionary of which the function is a member is needed
+-- [0] if the first superclass is needed (for example, the Eq dictionary for a member of Ord)
+-- [1] if the second superclass is needed, etc.
+-- [2,1] if the third superclass of the second superclass is needed
data GrBindAnn
= GrBindAnnNormal
| GrBindAnnClass [Maybe HsName]
| GrBindAnnInstance [Maybe HsName]
- | GrBindAnnOverloaded [Int]
+ | GrBindAnnOverloaded [[Int]]
| GrBindAnnSpecialized HsName Int [Maybe HsName]
deriving (Eq,Ord,Show)
@@ -126,7 +126,7 @@ pGrBindAnn :: GRIParser GrBindAnn
pGrBindAnn = pSucceed GrBindAnnNormal
<|> GrBindAnnClass <$ pKey "DICTCLASS" <*> pCurlyList pMbGrNm
<|> GrBindAnnInstance <$ pKey "DICTINSTANCE" <*> pCurlyList pMbGrNm
- <|> GrBindAnnOverloaded <$ pKey "DICTOVERLOADED" <*> pCurlyList pInt
+ <|> GrBindAnnOverloaded <$ pKey "DICTOVERLOADED" <*> pCurlyList (pCurlyList pInt)
<|> GrBindAnnSpecialized <$
pKey "SPECIALIZED" <*> pGrNm <*> pInt <*> pCurlyList pMbGrNm
@@ -110,6 +110,9 @@ ppCurlysSemisV :: [PP_Doc] -> PP_Doc
ppCurlysSemisV pL = vlist pL
%%]]
+-- list between {}, but with spaces, to avoid syntax clash with integers:
+-- {- comment -}
+-- {-1, -2}
ppCurlyList :: (a -> PP_Doc) -> [a] -> PP_Doc
ppCurlyList pL xs = ppListSep "{ " " }" ", " $ map pL xs
@@ -123,7 +126,7 @@ ppGrBindAnn :: PPGrNm -> GrBindAnn -> PP_Doc
ppGrBindAnn _ GrBindAnnNormal = pp ""
ppGrBindAnn ppGrNm (GrBindAnnClass xs) = pp "DICTCLASS" >|< ppCurlyList (ppMbGrNm ppGrNm) xs
ppGrBindAnn ppGrNm (GrBindAnnInstance xs) = pp "DICTINSTANCE" >|< ppCurlyList (ppMbGrNm ppGrNm) xs
-ppGrBindAnn _ (GrBindAnnOverloaded xs) = pp "DICTOVERLOADED" >|< ppCurlyList ppInt xs
+ppGrBindAnn _ (GrBindAnnOverloaded xs) = pp "DICTOVERLOADED" >|< ppCurlyList (ppCurlyList ppInt) xs
ppGrBindAnn ppGrNm (GrBindAnnSpecialized nm i xs) = pp "SPECIALIZED" >#< (ppGrNm nm) >#< show i >#< ppCurlyList (ppMbGrNm ppGrNm) xs
ppMbGrNm :: PPGrNm -> Maybe HsName -> PP_Doc
@@ -157,8 +157,11 @@ envChanges equat env
findFinalValueIntern nodes
= do { let x = AbsNodes (Nodes (Map.filterWithKey (const . isFinalTag) nodes))
- ; zs <- mapM (readAV2 False env) [ getNr nm | (GrTag_App nm) <- Map.keys nodes ]
+ --; zs <- mapM (readAV2 False env) [ getNr (trace (show nm ++ " = " ++ show f ++ "\n") nm) | (GrTag_App nm, (f:_)) <- Map.toList nodes ]
+ ; zs <- mapM (readAV2 False env) [ getNr nm | (GrTag_App nm, (f:_)) <- Map.toList nodes ]
; avs <- mapM (findFinalValue undefined) zs
+ --; qs <- mapM (readAV2 False env) (concat [ Set.toList f | (GrTag_App nm, (f:_)) <- Map.toList nodes ])
+ --; avs <- mapM (findFinalValue undefined) qs
; return (mconcat (x:avs))
}
@@ -198,20 +201,20 @@ envChanges equat env
%%[(8 codegen grin)
-fixpoint procEqs
+fixpoint procEqs env
= countFixpoint 0
where
countFixpoint count = do
{
changes <- procEqs
- --; ae <- getAssocs env
+ ; ae <- getAssocs env
--; let s = unlines (("SOLUTION": map show ae))
--; _ <- unsafePerformIO (do { writeFile ("hpt"++ show count++".txt") s
-- ; return (return ())
-- }
-- )
- --; _ <- trace ("fix " ++ show count ++ ": " ++ show changes ++ " changes") (return ())
+ -- ; _ <- trace ("fix " ++ show count ++ ": " ++ show changes ++ " changes") (return ())
; if changes>0
then countFixpoint (count+1)
@@ -234,13 +237,13 @@ solveEquations :: Int -> Equations -> Limitations -> (Int,HptMap)
solveEquations lenEnv eqs lims =
runST (
do {
- --; let eqsStr = unlines (map show eqs )
+ ; let eqsStr = unlines (map show eqs )
--; let limsStr = unlines (map show lims)
- --; _ <- unsafePerformIO (do { writeFile ("eqs .txt") eqsStr
+ ; _ <- unsafePerformIO (do { writeFile ("eqs.txt") eqsStr
-- ; writeFile ("lims.txt") limsStr
- -- ; return (return ())
- -- }
- -- )
+ ; return (return ())
+ }
+ )
-- create arrays
; env <- newArray (0, lenEnv-1) (True,False,AbsBottom)
@@ -286,7 +289,7 @@ solveEquations lenEnv eqs lims =
; _ <- mapM procEq eqs1a
- ; count <- fixpoint procEqs
+ ; count <- fixpoint procEqs env
; let limsMp = Map.fromList lims
lims2 = [ (y,z)
@@ -146,7 +146,7 @@ unifyNodes (p:ps) (x:xs) = let (a1,a2) = unifyNodes ps xs
unifyVars :: GrVar -> GrVal -> SubstTrafoPair
unifyVars GrVar_Ignore _ = (id, id)
unifyVars (GrVar_KnownTag t1) (GrVal_Tag t2) | t1==t2 = (id, id)
- | otherwise = error "CopyProp: unify: tags do not match"
+ | otherwise = error $ "CopyProp: unify: tags do not match: " ++ show t1 ++ " and " ++ show t2
unifyVars (GrVar_KnownTag t1) (GrVal_Var v2) = (id, Map.insert v2 (GrVal_Tag t1))
unifyVars (GrVar_KnownTag _ ) _ = (id,id)
unifyVars (GrVar_Var v1) x = (Map.insert v1 x, id)
Oops, something went wrong.

0 comments on commit 70b02bc

Please sign in to comment.