Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP

Comparing changes

Choose two branches to see what’s changed or to start a new pull request. If you need to, you can also compare across forks.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also compare across forks.
...
  • 3 commits
  • 36 files changed
  • 0 commit comments
  • 1 contributor
Commits on Mar 30, 2010
ajploeg Branch for my master project involving delayed closure construction. c368202
Commits on Apr 08, 2010
ajploeg Introduces frames on the heap and meta-closures. Both work!
Major Changes:
Modifications to Grin and Silly AbsSyn to incoperate meta-closures.
Introduces a new Grin transformation: IntroMeta which introduces meta-closures by converting F-tags this is done just after the NumberIdents Grin trf.
Grin trf InlineEA produces code for the new M (Meta) tags
Grin trfs SplitFetch and LowerGrin (locally) replace variables which might be used by meta-closures so they are followed by a new transformation: SubstMeta which globally replaces variables use in meta-closures.
Silly trf EmbedVars is heavily altered: 
	- put frames on the heap instead of stack space
        - translates the new variable offsets used in meta-closures to actual offsets

Bugs/Considerations:

Apperantly the LowerGrin transformation in combination with meta-closures messes up the HPT table, because a subsequent ImpossibleCase transformation will remove to 
many cases causing the program to crash. For this reason the last ImpossibleCase trf is currently disabled. Fixing this is the next thing to do....

The program crashes as soon as the Boehm garbage collector tries to collect. This is because frames are now on the heap and are not specified as a root-set. 
This will not be fixed, instead I will make the whole thing work with the new GC.
4e1daf8
ajploeg Fixes the bug that impossible case trf removes too many cases. Turns …
…out that the meta-tags in the AST where substituted, while the meta-tags in the HPT table remained the same. The meta-tags in the HPT table are now also updated.
dfaa1fe
Showing with 873 additions and 146 deletions.
  1. +0 −1  EHC/SVNREVISION
  2. +4 −1 EHC/src/ehc/Base/Opts.chs
  3. +25 −8 EHC/src/ehc/EHC/GrinCompilerDriver.chs
  4. +2 −1  EHC/src/ehc/GrinCode.cag
  5. +17 −2 EHC/src/ehc/GrinCode/AbsSyn.cag
  6. +8 −2 EHC/src/ehc/GrinCode/Common.chs
  7. +1 −1  EHC/src/ehc/GrinCode/FreeVars.cag
  8. +26 −7 EHC/src/ehc/GrinCode/PointsToAnalysis.cag
  9. +16 −1 EHC/src/ehc/GrinCode/Pretty.cag
  10. +7 −7 EHC/src/ehc/GrinCode/SolveEqs.chs
  11. +4 −1 EHC/src/ehc/GrinCode/ToGrinByteCode.cag
  12. +41 −8 EHC/src/ehc/GrinCode/ToSilly.cag
  13. +2 −1  EHC/src/ehc/GrinCode/Trf/CopyPropagation.cag
  14. +6 −2 EHC/src/ehc/GrinCode/Trf/DropUnreachableBindings.cag
  15. +27 −4 EHC/src/ehc/GrinCode/Trf/DropUnusedExpr.cag
  16. +29 −9 EHC/src/ehc/GrinCode/Trf/InlineEA.cag
  17. +77 −0 EHC/src/ehc/GrinCode/Trf/IntroMeta.cag
  18. +4 −0 EHC/src/ehc/GrinCode/Trf/LateInline.cag
  19. +29 −2 EHC/src/ehc/GrinCode/Trf/LowerGrin.cag
  20. +4 −0 EHC/src/ehc/GrinCode/Trf/NumberIdents.cag
  21. +1 −1  EHC/src/ehc/GrinCode/Trf/SetGrinInvariant.cag
  22. +1 −1  EHC/src/ehc/GrinCode/Trf/SpecConst.cag
  23. +26 −9 EHC/src/ehc/GrinCode/Trf/SplitFetch.cag
  24. +3 −1 EHC/src/ehc/GrinCode/Trf/SubstExpr.cag
  25. +67 −0 EHC/src/ehc/GrinCode/Trf/SubstMeta.cag
  26. +1 −1  EHC/src/ehc/Silly.cag
  27. +9 −2 EHC/src/ehc/Silly/AbsSyn.cag
  28. +18 −1 EHC/src/ehc/Silly/ElimUnused.cag
  29. +275 −14 EHC/src/ehc/Silly/EmbedVars.cag
  30. +6 −1 EHC/src/ehc/Silly/GroupAllocs.cag
  31. +47 −1 EHC/src/ehc/Silly/InlineExpr.cag
  32. +11 −4 EHC/src/ehc/Silly/Pretty.cag
  33. +60 −40 EHC/src/ehc/Silly/PrettyC.cag
  34. +15 −8 EHC/src/ehc/Silly/PrettyS.cag
  35. +2 −3 EHC/src/ehc/Silly/ToLLVM.cag
  36. +2 −1  EHC/src/ehc/files-ag-s.dep
View
1  EHC/SVNREVISION
@@ -1 +0,0 @@
-1873:1881M
View
5 EHC/src/ehc/Base/Opts.chs
@@ -224,6 +224,7 @@ data EHCOpts
, ehcOptGenRTSInfo :: Int -- flags to tell rts to dump internal info, currently: 1=on
, ehcOptDumpGrinStages :: Bool -- dump intermediate Grin transformation stages
+ , ehcOptMetaClosures :: Bool -- use meta-closures
, ehcOptEarlyModMerge :: Bool -- produce OneBigCore instead of OneBigGrin; useful for future Core-only optimizations
%%]]
%%[[8
@@ -404,7 +405,7 @@ defaultEHCOpts
, ehcOptGenTrace = False
, ehcOptGenTrace2 = False
, ehcOptGenRTSInfo = 0
-
+ , ehcOptMetaClosures = True
, ehcOptDumpGrinStages = False
, ehcOptEarlyModMerge = False
%%]]
@@ -546,6 +547,7 @@ ehcCmdLineOpts
, Option "" ["gen-trace-assign"] (boolArg optSetGenTrace2) "trace assignments in C (no)"
, Option "" ["gen-rtsinfo"] (ReqArg oRTSInfo "<nr>") "flags for rts info dumping (default=0)"
, Option "" ["dump-grin-stages"] (boolArg optDumpGrinStages) "dump intermediate Grin and Silly transformation stages (no)"
+ , Option "" ["meta-closures"] (boolArg optMetaClosures) "use meta-closures (yes)"
, Option "" ["early-mod-merge"] (boolArg optEarlyModMerge) "merge modules early, at Core stage (no)"
%%][100
%%]]
@@ -869,6 +871,7 @@ optSetGenRVS o b = o { ehcOptGenRVS = b }
optSetGenLink o b = o { ehcOptGenLink = b }
optSetGenLocReg o b = o { ehcOptGenLocReg = b }
optSetGenDebug o b = o { ehcOptGenDebug = b }
+optMetaClosures o b = o { ehcOptMetaClosures = b }
optDumpGrinStages o b = o { ehcOptDumpGrinStages = b {-, ehcOptEmitGrin = b -} }
optEarlyModMerge o b = o { ehcOptEarlyModMerge = b }
%%]
View
33 EHC/src/ehc/EHC/GrinCompilerDriver.chs
@@ -53,6 +53,10 @@
%%]
%%[(8 codegen grin) import({%{EH}GrinCode.Trf.DropUnusedExpr(dropUnusedExpr)})
%%]
+%%[(8 codegen grin) import({%{EH}GrinCode.Trf.IntroMeta(introMeta)})
+%%]
+%%[(8 codegen grin) import({%{EH}GrinCode.Trf.SubstMeta(substMeta,TagMap)})
+%%]
%%[(8 codegen grin) import({%{EH}GrinCode.PointsToAnalysis(heapPointsToAnalysis)})
%%]
%%[(8 codegen grin) import({%{EH}GrinCode.Trf.InlineEA(inlineEA)})
@@ -83,8 +87,6 @@
%%]
%%[(8 codegen grin) import({%{EH}Silly.ElimUnused(elimUnused)})
%%]
-%%[(8 codegen grin) import({%{EH}Silly.GroupAllocs(groupAllocs)})
-%%]
%%[(8 codegen grin) import({%{EH}Silly.EmbedVars(embedVars)})
%%]
%%[(8 codegen grin) import({%{EH}Silly.Pretty(pretty)})
@@ -183,12 +185,13 @@ doCompileGrin input opts
; transformCode setGrinInvariant "SetGrinInvariant" ; caWriteGrin "-128-invariant"
; checkCode checkGrinInvariant "CheckGrinInvariant"
-
; transformCode numberIdents "NumberIdents" ; caWriteGrin "-129-numbered"
+ ; when (ehcOptMetaClosures options)
+ (do transformCode introMeta "IntroMeta" ; caWriteGrin "-129_2-intrometa")
; caHeapPointsTo ; caWriteHptMap "-130-hpt"
; transformCodeChgHpt (inlineEA False) "InlineEA"
; transformCode grFlattenSeq "Flatten" ; caWriteGrin "-131-evalinlined"
-
+ ; caWriteHptMap "-131-hpt"
; transformCodeUseHpt impossibleCase "ImpossibleCase" ; caWriteGrin "-132-possibleCase"
@@ -196,8 +199,9 @@ doCompileGrin input opts
; transformCode emptyAlts "EmptyAlts" ; caWriteGrin "-133-emptyAlts"
; transformCode (dropUnreachableBindings True)
"DropUnreachableBindings" ; caWriteGrin "-134-reachable"
- ; transformCodeChgHpt lateInline "LateInline"
- ; transformCode grFlattenSeq "Flatten" ; caWriteGrin "-135-lateinlined"
+ ; when (ehcOptMetaClosures options)
+ ( do transformCodeChgHpt lateInline "LateInline";
+ transformCode grFlattenSeq "Flatten" ; caWriteGrin "-135-lateinlined" )
; transformCode emptyAlts "EmptyAlts" ; caWriteGrin "-136-emptyAlts"
; transformCodeUseHpt impossibleCase "ImpossibleCase" ; caWriteGrin "-141-possibleCase"
; transformCode emptyAlts "EmptyAlts" ; caWriteGrin "-142-emptyAlts"
@@ -205,7 +209,7 @@ doCompileGrin input opts
; transformCode grFlattenSeq "Flatten" ; caWriteGrin "-143-singleCase"
; transformCodeIterated dropUnusedExpr "DropUnusedExpr" ; caWriteGrin "-144-unusedExprDropped"
; transformCode mergeCase "MergeCase" ; caWriteGrin "-145-caseMerged"
- ; transformCodeChgHpt lowerGrin "LowerGrin" ; caWriteGrin "-151-lowered"
+ ; transformCodeChgHptChgMeta lowerGrin "LowerGrin" ; caWriteGrin "-151-lowered"
; caWriteHptMap "-152-hpt"
; transformCodeIterated copyPropagation "CopyPropagation" ; caWriteGrin "-161-after-cp"
; transformCodeUseHpt impossibleCase "ImpossibleCase" ; caWriteGrin "-162-possibleCase"
@@ -214,7 +218,7 @@ doCompileGrin input opts
; transformCodeIterated dropUnusedExpr "DropUnusedExpr" ; caWriteGrin "-169-unusedExprDropped"
- ; transformCodeChgHpt splitFetch "SplitFetch" ; caWriteGrin "-171-splitFetch"
+ ; transformCodeChgHptChgMeta splitFetch "SplitFetch" ; caWriteGrin "-171-splitFetch"
; caWriteHptMap "-172-hpt"
; transformCodeIterated dropUnusedExpr "DropUnusedExpr" ; caWriteGrin "-176-unusedExprDropped"
; transformCodeIterated copyPropagation "copyPropagation" ; caWriteGrin "-179-final"
@@ -485,6 +489,19 @@ transformCodeChgHpt process message
; gcsPutCodeHpt (process tup)
}
+transformCodeChgHptChgMeta :: ((GrModule,HptMap) -> (GrModule,TagMap,HptMap)) -> String -> CompileAction ()
+transformCodeChgHptChgMeta process message
+ = do { putMsg VerboseALot message Nothing
+ ; tup <- gcsGetCodeHpt
+ ; opts <- gets gcsOpts
+ ; let res = let (trf,tagMap,hptMap) = process tup
+ (trf2,hptMap2) = if ehcOptMetaClosures opts
+ then substMeta tagMap (trf,hptMap)
+ else (trf,hptMap)
+ in (trf2,hptMap2)
+ ; gcsPutCodeHpt res
+ }
+
transformCodeIterated :: (GrModule->(GrModule,Bool)) -> String -> CompileAction ()
transformCodeIterated process message
= task VerboseALot message (caFixCount 1) (\i -> Just $ show i ++ " iteration(s)")
View
3  EHC/src/ehc/GrinCode.cag
@@ -25,7 +25,7 @@
%%[(8 codegen grin) hs export(GrType(..), GrTypeBase(..), GrTypeBaseL)
%%]
-%%[(8 codegen grin) hs export(GrAlt(..), GrAltL, GrPatAlt(..), GrPatLam(..), GrVal(..), GrValL, GrTag(..), GrTagL, GrVar(..), GrVarL)
+%%[(8 codegen grin) hs export(GrAlt(..), GrAltL, GrPatAlt(..), GrPatLam(..), GrVal(..), GrValL, GrTag(..), GrTagL, GrVar(..), GrVarL, GrVarOffset(..), GrVarOffsetL)
%%]
%%[(10 codegen grin) hs export(GrAdapt(..), GrAdaptL, GrSplit(..), GrSplitL)
@@ -92,6 +92,7 @@ data GrTagAnn
instance Eq GrTag where
GrTag_Con _ _ x1 == GrTag_Con _ _ x2 = x1==x2
GrTag_Fun x1 == GrTag_Fun x2 = x1==x2
+ GrTag_Meta nm args == GrTag_Meta nm' args' = nm == nm' && args == args'
GrTag_App x1 == GrTag_App x2 = x1==x2
GrTag_PApp n1 x1 == GrTag_PApp n2 x2 = n1==n2 && x1==x2
GrTag_Unboxed == GrTag_Unboxed = True
View
19 EHC/src/ehc/GrinCode/AbsSyn.cag
@@ -60,6 +60,8 @@ DATA GrExpr
| FetchField nm : {HsName}
offset : {Int}
mbTag : {Maybe GrTag}
+ | FetchVar nm : {HsName}
+ varos : GrVarOffset
| Store val : GrVal
| Call nm : {HsName}
argL : GrValL
@@ -96,6 +98,7 @@ DATA GrVal
| Node tag : GrTag
fldL : GrValL
| OpaqueNode nm : {HsName}
+ | This
%%[[10
| NodeAdapt nm : {HsName}
fldL : GrAdaptL
@@ -137,10 +140,21 @@ DATA GrTag
| PApp needs : {Int}
nm : {HsName}
| App nm : {HsName}
+ | Meta nm : {HsName}
+ args : GrVarOffsetL
| Unboxed
| Hole
| Rec
+DATA GrVarOffset
+ | GrVarOffset inFrameOf : {HsName} -- because names are unique, this is unnecessary
+ var : {HsName}
+
+TYPE GrVarOffsetL = [GrVarOffset]
+
+DERIVING GrVarOffsetL GrVarOffset: Eq,Ord
+
+
TYPE GrTagL = [GrTag]
%%]
@@ -230,8 +244,9 @@ SET AllBind = GrBind GrBindL
SET AllDef = AllGlobal AllBind
SET AllAlt = GrAlt GrAltL
SET AllGrExpr = GrExpr AllAlt
-SET AllGrTag = GrTag GrTagL
-SET AllExpr = AllGrExpr AllGrPat AllGrTag AllGrVal AllType
+SET AllGrTag = GrTag GrTagL
+SET AllExpr = AllGrExpr AllGrPat AllGrTag AllGrVal AllType AllGrVarOffset
+SET AllGrVarOffset = GrVarOffset GrVarOffsetL
%%[[10
SET AllAdapt = GrAdapt GrAdaptL
SET AllSplit = GrSplit GrSplitL
View
10 EHC/src/ehc/GrinCode/Common.chs
@@ -129,6 +129,7 @@ conNumber GrTag_Hole = 7
-- Unevaluated tags last
conNumber (GrTag_Fun _) = 8
conNumber (GrTag_App _) = 9
+conNumber (GrTag_Meta _ _) = 10
conName :: GrTag -> HsName
@@ -136,6 +137,10 @@ conName (GrTag_App nm) = nm
conName (GrTag_Fun nm) = nm
conName (GrTag_PApp _ nm) = nm
conName (GrTag_Con _ _ nm) = nm
+conName (GrTag_Meta nm _ ) = nm
+
+conArgs (GrTag_Meta _ args) = args
+conArgs _ = error "Con args called on non-meta tag"
conInt :: GrTag -> Int
conInt (GrTag_PApp i _ ) = i
@@ -150,7 +155,9 @@ instance Ord GrTag where
EQ
else -- App/Fun/PApp/Con, all have a name
case cmpHsNameOnNm (conName t1) (conName t2) of
- EQ -> if x >= 8
+ EQ -> if x == 10 -- is it a meta closure tag?
+ then compare (conArgs t1) (conArgs t2)
+ else if x >= 8
then -- App/Fun
EQ
else -- Papp/Con, both have an int
@@ -158,7 +165,6 @@ instance Ord GrTag where
a -> a
a -> a
-
%%]
View
2  EHC/src/ehc/GrinCode/FreeVars.cag
@@ -40,5 +40,5 @@ WRAPPER GrExpr
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%[(8 codegen grin)
-ATTR GrTag [ | | trf: SELF ]
+ATTR GrTag GrVarOffset GrVarOffsetL [ | | trf: SELF ]
%%]
View
33 EHC/src/ehc/GrinCode/PointsToAnalysis.cag
@@ -103,7 +103,9 @@ SEM GrAGItf
%%]
%%[(8 codegen grin)
-ATTR AllGrVal AllGrTag [ | | self : SELF ]
+ATTR AllGrVal AllGrTag AllGrVarOffset [ | | self : SELF ]
+
+
%%]
@@ -138,7 +140,8 @@ ATTR GrValL [ | | valsInfo: {[NodeInfo (Maybe Variable)]} vars : {[
ATTR GrPatAlt GrPatLam [ | | patInfo : { NodeInfo Variable } tag : { Maybe GrTag} ]
ATTR GrVar [ | | tag : GrTag var : { Variable } ]
ATTR GrVarL [ | | headTag : GrTag vars : {[Variable]} ]
-
+ATTR GrVarOffset [ | | var : { Variable } ]
+ATTR GrVarOffsetL [ | | vars : {[Variable]} ]
SEM GrModule
| Mod bindL.tagsMp = @tagsMp
@@ -151,10 +154,12 @@ SEM GrVal
| EnumNode lhs.valInfo = InEnum (getNr @nm) []
| OpaqueNode lhs.valInfo = InNode GrTag_Unboxed [Just(getNr @nm)]
| PtrNode lhs.valInfo = InPtr (getNr @nm)
+ | This lhs.valInfo = error $ "HPT : valinfo this has no known tag"
| Empty
LitInt
LitStr
VarNode
+
%%[[10
NodeAdapt
%%]]
@@ -217,6 +222,12 @@ SEM GrVar
| Ignore lhs.var = 0
| KnownTag lhs.var = error "var taken from KnownTag"
+SEM GrVarOffset
+ | GrVarOffset lhs.var = getNr @var
+
+SEM GrVarOffsetL
+ | Cons lhs.vars = @hd.var : @tl.vars
+ | Nil lhs.vars = []
%%]
%%[(8 codegen grin) hs
@@ -327,6 +338,7 @@ An equation is generated, which states that the targetvariable is known to be as
tagFun :: GrTag -> Maybe Int
tagFun (GrTag_Fun nm) = Just (getNr nm) -- track overwrite results of Fun
tagFun (GrTag_App nm) = Just (getNr nm) -- also track overwrite results of App
+tagFun (GrTag_Meta nm _ ) = Just (getNr nm)
tagFun _ = Nothing
}
@@ -519,17 +531,24 @@ SEM GrBind
%%[(8 codegen grin)
-- Collect all Fun, PApp and App nodes, and all Calls
-ATTR AllGrVal AllGrExpr AllDef GrModule [ | | allCalls USE {++} {[]} : {AbstractCallList} ]
-ATTR GrTag [ | | mbFPAnr : {Maybe Int} ]
+ATTR AllGrVal AllGrExpr AllDef GrModule [ | | allCalls USE {++} {[]} : {AbstractCallList} ]
+ATTR GrTag [ | | mbFPAnr : {Maybe Int} ]
+ATTR GrTag [ | | call : {Maybe AbstractCall}]
SEM GrVal
- | Node lhs . allCalls = maybe [] (\n->[(n, @fldL.vars)]) @tag.mbFPAnr
+ | Node lhs . allCalls = case @tag.call of
+ Just cl -> [cl]
+ _ -> maybe [] (\n->[(n, @fldL.vars)]) @tag.mbFPAnr
SEM GrExpr
| Call lhs . allCalls = [ (getNr @nm, @argL.vars) ]
SEM GrTag
- | Fun PApp App lhs . mbFPAnr = Just (getNr @nm)
- | * - Fun PApp App lhs . mbFPAnr = Nothing
+ | Fun PApp App Meta lhs . mbFPAnr = Just (getNr @nm)
+ | * - Fun PApp App Meta lhs . mbFPAnr = Nothing
+
+SEM GrTag
+ | Meta lhs . call = Just (getNr @nm,map Just @args.vars)
+ | * - Meta lhs . call = Nothing
%%]
View
17 EHC/src/ehc/GrinCode/Pretty.cag
@@ -224,6 +224,7 @@ SEM GrExpr
| FetchNode lhs . pp = "fetchnode" >#< @lhs.ppGrNm @nm
| FetchField lhs . pp = "fetchfield" >#< @lhs.ppGrNm @nm >#< pp @offset >#< maybe empty ppGrTag @mbTag
| FetchUpdate lhs . pp = "fetchupdate" >#< @lhs.ppGrNm @src >#< @lhs.ppGrNm @dst
+ | FetchVar lhs . pp = "fetchvar" >#< @lhs.ppGrNm @nm>#< @varos.pp
| Throw lhs . pp = "throw" >#< @lhs.ppGrNm @nm
| Catch lhs . pp = "try" >-<
indent 2 (ppCurlysSemisV [@body.pp]) >-<
@@ -243,6 +244,7 @@ SEM GrVal
| Var lhs . pp = @lhs.ppGrNm @nm
| Node lhs . pp = ppListSep "(" ")" " " (@tag.pp : @fldL.ppL)
| VarNode lhs . pp = ppListSep "(" ")" " " ( @fldL.ppL)
+ | This lhs . pp = pp "this"
%%[[8
| BasicNode lhs . pp = ppListSep "(" ")" " " [pp "basicnode", @tag.pp, @lhs.ppGrNm @nm]
| EnumNode lhs . pp = ppListSep "(" ")" " " [pp "enumnode" , @lhs.ppGrNm @nm]
@@ -316,6 +318,7 @@ SEM GrTag
| Fun lhs . pp = "#" >|< "0" >|< "/" >|< "F" >|< "/" >|< @lhs.ppGrNm @nm
| PApp lhs . pp = "#" >|< "0" >|< "/" >|< "P" >|< "/" >|< @needs >|< "/" >|< @lhs.ppGrNm @nm
| Con lhs . pp = "#" >|< @int >|< "/" >|< "C" >|< show @grtgAnn >|< "/" >|< @lhs.ppGrNm @nm
+ | Meta lhs . pp = "#" >|< "0" >|< "/" >|< "M" >|< "/" >|< @lhs.ppGrNm @nm >|< "/" >|< ppCurlysSemisV @args.ppL
%%][8_2
| Hole lhs . pp = pp "Hole"
| Rec lhs . pp = "R" >|< @lhs.ppGrNm (mkHNm "()")
@@ -323,12 +326,20 @@ SEM GrTag
| Fun lhs . pp = "F" >|< pp @nm
| PApp lhs . pp = "P" >|< pp @nm >|< @needs
| Con lhs . pp = "C" >|< pp @nm
+ | Meta lhs . pp = "M" >|< pp @nm >|< ppCurlysSemisV @args.ppL
%%]]
| Unboxed lhs . pp = pp "#U"
%%]
%%[(8 codegen grin)
-ATTR GrGlobalL GrBindL GrAltL GrTagL GrValL GrVarL [ | | ppL: {[PP_Doc]} ]
+
+SEM GrVarOffset
+ | GrVarOffset lhs . pp = cfgppHsName CfgPP_Grin @inFrameOf >|< "/" >|< cfgppHsName CfgPP_Grin @var
+
+%%]
+
+%%[(8 codegen grin)
+ATTR GrGlobalL GrBindL GrAltL GrTagL GrValL GrVarL GrVarOffsetL [ | | ppL: {[PP_Doc]} ]
SEM GrGlobalL
| Cons lhs . ppL = @hd.pp : @tl.ppL
@@ -357,6 +368,10 @@ SEM GrValL
SEM GrVarL
| Cons lhs . ppL = @hd.pp : @tl.ppL
| Nil lhs . ppL = []
+
+SEM GrVarOffsetL
+ | Cons lhs . ppL = @hd.pp : @tl.ppL
+ | Nil lhs . ppL = []
%%]
%%[(10 codegen grin)
ATTR GrAdaptL GrSplitL [ | | ppL: {[PP_Doc]} ]
View
14 EHC/src/ehc/GrinCode/SolveEqs.chs
@@ -237,13 +237,13 @@ solveEquations :: Int -> Equations -> Limitations -> (Int,HptMap)
solveEquations lenEnv eqs lims =
runST (
do {
- --; let eqsStr = unlines (map show eqs )
- --; let limsStr = unlines (map show lims)
- --; _ <- unsafePerformIO (do { writeFile ("eqs.txt") eqsStr
- -- ; writeFile ("lims.txt") limsStr
- -- ; return (return ())
- -- }
- -- )
+ ; let eqsStr = unlines (map show eqs )
+ ; let limsStr = unlines (map show lims)
+ ; _ <- unsafePerformIO (do { writeFile ("eqs.txt") eqsStr
+ ; writeFile ("lims.txt") limsStr
+ ; return (return ())
+ }
+ )
-- create arrays
; env <- newArray (0, lenEnv-1) (True,False,AbsBottom)
View
5 EHC/src/ehc/GrinCode/ToGrinByteCode.cag
@@ -796,6 +796,8 @@ SEM GrExpr
where (GB.GrValIntroAlt_OnTOS ins inc _ _, gbState)
= GB.gviLd @lhs.opts GB.defaultLoadCtxt @nmEnv @ldStState @expr.gbState gvi
_ -> nm Seq.empty (GB.ststFromDep 0) @expr.gbState @pat.nmIntro
+ | FetchVar loc . (seqIns,seqStInc,newVaGam,aftLdGBState) = error "Fetchfield is forbidden when translating to GrinByte code"
+ | FetchVar loc . (valIns,valStInc,retIsDone,scrutineeStInc) = error "Fetchfield is forbidden when translating to GrinByte code"
%%]
%%[(8 codegen grin) hs
@@ -981,6 +983,7 @@ SEM GrPatLam
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%[(8 codegen grin)
-ATTR GrTag [ | | self: SELF ]
+ATTR GrTag AllGrVarOffset [ | | self: SELF ]
+
%%]
View
49 EHC/src/ehc/GrinCode/ToSilly.cag
@@ -18,7 +18,7 @@ Transforms a Grin program to a Silly program.
%%[(8 codegen grin) hs import(Debug.Trace)
%%]
-%%[(8 codegen grin) hs import(Data.List((\\)), Data.Maybe, qualified Data.Map as Map, qualified Data.Set as Set, Data.Bits)
+%%[(8 codegen grin) hs import(Data.List((\\),intercalate), Data.Maybe, qualified Data.Map as Map, qualified Data.Set as Set, Data.Bits)
%%]
%%[(8 codegen grin) hs import(EH.Util.Pretty, EH.Util.Utils)
%%]
@@ -131,7 +131,7 @@ SEM GrModule
loc . initFunction = Function_Function (hsnFromString "initialize") [] []
( @globalL.initStats1
++ @globalL.initStats2
- ++ [ Statement_Return [] Nothing ]
+ ++ [ Statement_Return [] Value_None ]
)
loc . maxConstrParameters = foldr max 0 (map tagArity (concat (Map.elems @tagsMp)))
loc . optGenReturnViaStack = ehcOptGenOwn @lhs.opts && not (ehcOptEmitLLVM @lhs.opts) && ehcOptGenRVS @lhs.opts
@@ -164,7 +164,7 @@ SEM GrExpr
lhs.stats = if not @lhs.hasNext
then assignments "Update" (map (arrayVariab @loc.name) [0..]) [] @val.values
++ [ Statement_Comment ["Return (Unit after Update)"]
- , Statement_Return @val.values Nothing
+ , Statement_Return @val.values Value_None
]
else maybe (assignments "UpdateUnit" (map (arrayVariab @loc.name) [0..]) (map mkVar @lhs.targets) @val.values)
(\t -> Statement_Comment ["Updateunit to PtrNode"] : store2 (mkVar t) (length @val.values) (length @val.values) (map (arrayVariab @loc.name) [0..]) @val.values)
@@ -172,7 +172,7 @@ SEM GrExpr
| Unit lhs.stats = if not @lhs.hasNext
then [ Statement_Comment ["Return (Unit)"]
- , Statement_Return @val.values Nothing
+ , Statement_Return @val.values Value_None
]
else maybe (assignments "Unit" [] (map mkVar @lhs.targets) @val.values)
(\t -> Statement_Comment ["Unit to PtrNode"] : store (mkVar t) (length @val.values) (length @val.values) @val.values)
@@ -181,7 +181,7 @@ SEM GrExpr
| FFI lhs.stats = if not @lhs.hasNext
then [ Statement_Comment ["Return (FFI)"]
- , Statement_Return [@loc.callres] Nothing
+ , Statement_Return [@loc.callres] Value_None
]
else case @lhs.targets
of [ HNmNr 0 _ ] -> [Statement_Comment ["FFI void"], Statement_Voiden @loc.callres]
@@ -226,6 +226,17 @@ SEM GrExpr
(arrayValue (mkVar @nm) @offset)
]
lhs.localsSet = Set.fromList @lhs.targets
+
+
+ | FetchVar lhs.stats = let ph = case @lhs.targets of
+ [] -> error ("ToSilly: FetchField has no target in " ++ show @lhs.functionName)
+ (x:_) -> x
+ in
+ [ Statement_Comment ["FetchVar"]
+ , Statement_Assignment (mkVar ph)
+ $ Value_OffsetVar (mkVar @nm) @varos.var
+ ]
+ lhs.localsSet = Set.fromList @lhs.targets
| Case lhs.stats = let comm = Statement_Comment ["Case"]
reenters = if null @altL.reenteralts
@@ -257,6 +268,7 @@ SEM GrExpr
)
lhs.localsSet = Set.fromList @lhs.targets
+
| App lhs.stats = [Statement_Comment ["App: SHOULDNT"]]
| Eval lhs.stats = [Statement_Comment ["Eval: SHOULDNT"]]
| Throw lhs.stats = [Statement_Comment ["Throw: TODO"]]
@@ -283,6 +295,8 @@ SEM GrGlobal
lhs.initStats2 = storePopulate (Variable_Global @globNm) @val.values
SEM GrVal
+ | This lhs.value = Value_This
+ lhs.values = error "Values of this in 2silly"
| LitInt lhs.value = Value_Con (Constant_LiteralInt @int)
| LitStr lhs.value = Value_Con (Constant_LiteralStr @str)
| Var
@@ -335,20 +349,34 @@ SEM GrValL
SEM GrTag
| Con loc.constant = Constant_Alias ("C" ++ hsnShowAlphanumericShort @nm)
| Fun loc.constant = Constant_Alias ("F" ++ hsnShowAlphanumericShort @nm)
+ | Meta loc.constant = Constant_Alias ("M" ++ hsnShowAlphanumericShort @nm ++ "_s_" ++ @args.constantPart)
| App loc.constant = Constant_Alias ("A" ++ hsnShowAlphanumeric @nm)
| PApp loc.constant = Constant_Alias ("P" ++ show @needs ++ "_" ++ hsnShowAlphanumericShort @nm)
| Hole loc.constant = Constant_Alias ("HOLE")
- | Con Fun App PApp Hole
+ | Con Fun App PApp Hole Meta
lhs.constant = @loc.constant
lhs.value = Value_Con (@loc.constant)
| Unboxed lhs.value = Value_Con (Constant_Alias "UNBOXED")
| Unboxed lhs.constant = Constant_Alias "UNBOXED"
- | * - Con Fun App PApp Hole Unboxed
+ | * - Con Fun App PApp Hole Unboxed Meta
lhs.constant = error "GrTag:other constant"
lhs.value = error "GrTag:other value"
+ATTR AllGrVarOffset [ | | constantPart : {String}]
+ATTR GrVarOffset [ | | var : HsName ]
+
+SEM GrVarOffset
+ | GrVarOffset lhs.var = @var
+
+SEM GrVarOffset
+ | GrVarOffset lhs.constantPart = hsnShowAlphanumericShort @var
+
+SEM GrVarOffsetL
+ | Cons lhs.constantPart = @hd.constantPart ++ (if null @tl.self then [] else "__" ++ @tl.constantPart)
+ | Nil lhs.constantPart = []
+
SEM GrPatAlt
| Tag lhs.value = @tag.value
lhs.constant = @tag.constant
@@ -356,6 +384,7 @@ SEM GrPatAlt
lhs.constant = error "GrPatAlt:other constant"
-- TODO: | LitInt = ...
+
%%]
@@ -434,7 +463,7 @@ ATTR GrModule GrBind GrBindL GrExpr GrAlt GrAltL
ATTR AllDef AllExpr [ | | genAllTags USE {`Set.union`} {Set.empty} : {Set.Set GrTag} ]
-ATTR GrTag [ | | self : SELF ]
+ATTR GrTag AllGrVarOffset [ | | self : SELF ]
SEM GrTag
| * lhs.genAllTags = Set.singleton @loc.self
@@ -594,6 +623,10 @@ tagConstants opts tagset
showGrTag :: GrTag -> String
showGrTag (GrTag_Con a i nm) = "C" ++ hsnShowAlphanumericShort nm
showGrTag (GrTag_Fun nm) = "F" ++ hsnShowAlphanumericShort nm
+showGrTag (GrTag_Meta nm args) = let name = "M" ++ hsnShowAlphanumericShort nm ++ "_s_" ++ (intercalate "__" (map getArgName args))
+ in trace ("tag found: " ++ name) name
+ where
+ getArgName (GrVarOffset_GrVarOffset _ nm) = hsnShowAlphanumericShort nm
showGrTag (GrTag_PApp n nm) = "P" ++ show n ++ "_" ++ hsnShowAlphanumericShort nm
showGrTag (GrTag_App nm) = "A" ++ hsnShowAlphanumeric nm
showGrTag (GrTag_Rec) = "GrTag:Rec"
View
3  EHC/src/ehc/GrinCode/Trf/CopyPropagation.cag
@@ -35,7 +35,8 @@ ATTR GrPatLam
GrVarL
GrVar
GrTagL
- GrTag [ | | self: SELF ]
+ GrTag
+ AllGrVarOffset [ | | self: SELF ]
ATTR GrAGItf GrModule AllBind GrExpr AllAlt [ | | changed USE {||} {False}: Bool ]
SEM GrExpr
View
8 EHC/src/ehc/GrinCode/Trf/DropUnreachableBindings.cag
@@ -3,6 +3,8 @@
Drop all functions not reachable from main,
either through direct calls, or through deferred (F) or partially applied (P) or apply (A) calls.
+updated to include (M) deferred calls
+
%%]
%%[0
@@ -106,7 +108,8 @@ SEM GrVal
SEM GrTag
| Fun
App
- PApp lhs.used = usedGlob @lhs.env @nm
+ PApp
+ Meta lhs.used = usedGlob @lhs.env @nm
SEM GrBind
@@ -167,7 +170,8 @@ SEM GrPatAlt
SEM GrTag
| Fun
PApp
- App lhs . life = Map.findWithDefault 0 @nm @lhs.env `Set.member` @lhs.lifeSet
+ App
+ Meta lhs . life = Map.findWithDefault 0 @nm @lhs.env `Set.member` @lhs.lifeSet
| Con
Unboxed
Hole
View
31 EHC/src/ehc/GrinCode/Trf/DropUnusedExpr.cag
@@ -3,9 +3,11 @@
If an expression is bound to a variable which is never used,
it is removed (if the expression has no side effect).
Variable bindings that are never used are replaced by wildcards.
-Global variables and functions thar are never used are removed.
+Global variables and functions that are never used are removed.
Alternatives with tags that involve functions that do no longer exist are removed.
+
+
%%]
%%[(8 codegen grin) ag import({GrinCode/AbsSyn})
@@ -46,10 +48,13 @@ ATTR GrAGItf GrModule AllBind AllGlobal AllGrExpr [ | | changes USE {||} {False}
-- This includes the use of function names in calls and F, P, and A-tags (but not in C-tags) used in values (but not in patterns and annotations).
-- Also we collect the free variables in the body of each binding of an global (this will be other function and global names).
+
+
ATTR AllGrExpr
AllGrVal
AllGrTag
AllBind
+ AllGrVarOffset
AllGlobal [ | | freeUsed USE {`Set.union`} {Set.empty}: {Set.Set HsName} ]
@@ -104,6 +109,7 @@ SEM GrExpr
| FetchNode lhs.freeUsed = Set.singleton @nm
| FetchUpdate lhs.freeUsed = Set.insert @src (Set.singleton @dst) -- Note: although @dst is not a "use", we do regard it as such, so that we won't be updating an eliminated variable
| FetchField lhs.freeUsed = Set.singleton @nm
+ | FetchVar lhs.freeUsed = Set.singleton @nm
| Call lhs.freeUsed = Set.insert @nm @argL.freeUsed
| Eval lhs.freeUsed = Set.singleton @nm
| App lhs.freeUsed = Set.insert @nm @argL.freeUsed
@@ -120,6 +126,10 @@ SEM GrTag
| Fun
PApp
App lhs.freeUsed = Set.singleton @nm
+ | Meta lhs.freeUsed = Set.insert @nm @args.freeUsed
+
+SEM GrVarOffset
+ | GrVarOffset lhs.freeUsed = Set.singleton @var -- Isn't really a use now, but the variable will be used later on when evaluating the meta-closure
-- In patterns we collect the variables that are bound
@@ -274,6 +284,8 @@ SEM GrSplit
-- (before version 1090 we had an additional test which removed code after an expression that always throws an exception.
-- This needed the HPT map to decide whether a Call always throws: if its result is Bottom, but its throw-result is not Bottom).
+
+
SEM GrExpr
| Seq (lhs.grTrf
,lhs.changes) = -- if @expr.throws then @expr.grTrf else
@@ -293,12 +305,17 @@ SEM GrVal
-- Bindings, Globals, and Alternatives that are not "life" are deleted.
-SEM GrBindL GrGlobalL GrAltL
+-- There is a problem here for meta-closures: we remove alternatives for tags of functions that are no longer used,
+-- however these may introduce a meta-closure tag. If we remove them we have the problem that we have
+-- meta closures which are eliminated but not introduced. Ideally we would also want to destroy meta-closures
+-- tag introduces in these alternative to be deleted.
+
+SEM GrBindL GrGlobalL
| Cons (lhs.grTrf
,lhs.changes) = if @hd.life
then ( @hd.grTrf : @tl.grTrf, @hd.changes || @tl.changes )
else ( @tl.grTrf, True )
-
+-- SEM GrAltL
%%]
@@ -319,6 +336,8 @@ SEM GrGlobal
-- C and special tags are always life.
-- An F, A or P tag is life if the corresponding function exists.
+
+
SEM GrAlt
| Alt lhs . life = maybe True
(\nm -> Set.member nm @lhs.globalUsed)
@@ -335,7 +354,8 @@ SEM GrPatAlt
SEM GrTag
| Fun
PApp
- App lhs.mbTagName = Just @nm
+ App
+ Meta lhs.mbTagName = Just @nm
| Con
Hole
Rec
@@ -348,6 +368,9 @@ SEM GrTag
-- Variables bound in patterns which are never used are replaced with wildcards.
-- (This is only important for the result of expressions that are kept because of their side effects)
+-- Updated to not delete variables used by meta-closures (the variables that are used are in the tag of the meta-closure).
+
+
SEM GrPatLam
| Var lhs . grTrf = GrPatLam_Var (mkWildcard @lhs.downstreamUsed @nm)
| BasicNode lhs . grTrf = GrPatLam_BasicNode @annot (mkWildcard @lhs.downstreamUsed @nm)
View
38 EHC/src/ehc/GrinCode/Trf/InlineEA.cag
@@ -68,8 +68,9 @@ maximum0 [] = 0
maximum0 xs = maximum xs
unevaluatedName :: GrTag -> Maybe HsName
-unevaluatedName (GrTag_Fun nm) = Just nm
-unevaluatedName (GrTag_App nm) = Just nm
+unevaluatedName (GrTag_Fun nm) = Just nm
+unevaluatedName (GrTag_App nm) = Just nm
+unevaluatedName (GrTag_Meta nm _) = Just nm
unevaluatedName _ = Nothing
isPartialApplication ((GrTag_PApp _ _), _) = True
@@ -202,7 +203,7 @@ SEM GrExpr
ATTR AllDef AllExpr [ | | genAllTags USE {`Map.union`} {Map.empty} : {Map.Map GrTag Int} ]
-ATTR GrTag [ | | self : SELF ]
+ATTR GrTag AllGrVarOffset [ | | self : SELF ]
SEM GrVal
| Node lhs.genAllTags = Map.singleton @tag.self (length @fldL.grTrf)
@@ -249,7 +250,22 @@ buildEvalAlt locatName locatNeedsUpdate nodeName unique hptMap (tag,args)
resultPat = GrPatLam_Var resultName
emptyPat = GrPatLam_Empty
-- generate code for the call
- callExpr0 = GrExpr_Call functName $ map GrVal_Var patNames
+ (callExpr0,unique4,newItems4) =
+ case tag of
+ -- here comes the meta closure specific stuff: fetch the variables denoted in the tag before calling
+ GrTag_Meta mnm args ->
+ let nrOfArgInTag (GrVarOffset_GrVarOffset _ varNm) = (getNr varNm)
+ argsInTagAbstractValues = map (getEnvVar hptMap) $ map nrOfArgInTag args
+ (uniqueM,newItemsM,fetchNames) = trace ("abstractvalues :" ++ show argsInTagAbstractValues) $ newNames unique3 argsInTagAbstractValues
+ fetches = map (GrExpr_FetchVar (head patNames)) args
+ pats = map GrPatLam_Var fetchNames
+ call = GrExpr_Call functName $ map GrVal_Var fetchNames
+ makeSequence (expr:[]) [] = expr
+ makeSequence (expr:exprs) (pat:pats) = GrExpr_Seq expr pat (makeSequence exprs pats)
+ callExpr = makeSequence (fetches ++ [call]) pats
+ in (callExpr,uniqueM,newItemsM)
+ _ -> (GrExpr_Call functName $ map GrVal_Var patNames, unique3,[])
+ -- this breaks the invariant that the left part of a seq in a single node, but no worries, flatten is the next transform
callExpr1 = GrExpr_Seq callExpr0 resultPat $
GrExpr_Unit resultVal GrType_None
callExpr2 = GrExpr_Seq callExpr0 resultPat $
@@ -258,7 +274,7 @@ buildEvalAlt locatName locatNeedsUpdate nodeName unique hptMap (tag,args)
then callExpr2
else callExpr1
in if isEmptyAbsVal exceptAbsVal
- then (unique3, newItems2++newItems3, codeHead (GrAltAnnCalling resultMaxArity locatName) callExpr )
+ then (unique4, newItems2++newItems3++newItems4, codeHead (GrAltAnnCalling resultMaxArity locatName) callExpr )
else -- handling exceptions below (currently not used)
let -- create some more new names
(unique4, newItems4, [throwVar,catchVar]) = newNames unique3 [exceptAbsVal, resultAbsVal]
@@ -496,16 +512,20 @@ ATTR GrTag [ | | mbFunNr : {Maybe Int} ]
SEM GrTag
| Fun
App
- PApp lhs.mbFunNr = Just (getNr @nm)
+ PApp
+ Meta lhs.mbFunNr = Just (getNr @nm)
| * - Fun
App
- PApp lhs.mbFunNr = Nothing
+ PApp
+ Meta lhs.mbFunNr = Nothing
SEM GrTag
| Fun
- App lhs.updateNeeded = True
+ App
+ Meta lhs.updateNeeded = True
| * - Fun
- App lhs.updateNeeded = False
+ App
+ Meta lhs.updateNeeded = False
SEM GrVal
| Node lhs.updateNeeded = @tag.updateNeeded
View
77 EHC/src/ehc/GrinCode/Trf/IntroMeta.cag
@@ -0,0 +1,77 @@
+%%[doesWhat doclatex
+
+Introduces tag for meta-closures
+
+%%]
+
+
+
+
+
+%%[0
+%include lhs2TeX.fmt
+%include afp.fmt
+%%]
+
+%%[(8 codegen grin) hs module {%{EH}GrinCode.Trf.IntroMeta} export(introMeta)
+%%]
+
+%%[(8 codegen grin) hs import(Data.Array.IArray, qualified Data.Set as Set, qualified Data.Map as Map, Data.Maybe)
+%%]
+%%[(8 codegen grin) hs import({%{EH}Base.Common}, {%{EH}Base.Builtin}, {%{EH}GrinCode})
+%%]
+%%[(8 codegen grin) hs import({%{EH}GrinCode.Common}, {%{EH}Config})
+%%]
+%%[(8 codegen grin) hs import(Debug.Trace)
+%%]
+
+%%[(8 codegen grin) ag import({GrinCode/AbsSyn})
+%%]
+
+
+%%[(8 codegen grin).wrapper
+WRAPPER GrAGItf
+%%]
+
+%%[(8 codegen grin) hs
+introMeta :: GrModule -> GrModule
+introMeta code
+ = let inh = Inh_GrAGItf {}
+ syn = wrap_GrAGItf (sem_GrAGItf (GrAGItf_AGItf code)) inh
+ in grTrf_Syn_GrAGItf syn
+%%]
+
+
+%%[(8 codegen grin)
+
+ATTR GrAGItf [ | | grTrf: GrModule ]
+ATTR AllNT [ | | grTrf: SELF ]
+
+
+SEM GrExpr
+ | Store lhs.grTrf = GrExpr_Store @val.converted
+
+ATTR AllExpr [ enclosingFun : {HsName} | | ]
+
+SEM GrBind
+ | Bind expr.enclosingFun = @nm
+
+ATTR AllExpr [ | | converted : SELF ]
+
+
+ATTR GrVal GrValL [ | | vars USE {++} {[]} : {[HsName]} ]
+
+SEM GrVal
+ | Var lhs.vars = [@nm]
+
+SEM GrVal
+ | Node lhs.converted = case @tag.converted of
+ GrTag_Fun nm -> GrVal_Node (makeMetaTag @lhs.enclosingFun nm @fldL.vars) [GrVal_This]
+ _ -> GrVal_Node @tag.converted @fldL.converted
+
+{
+makeMetaTag encl fun args =
+ GrTag_Meta fun $ map (GrVarOffset_GrVarOffset encl) args
+}
+
+%%]
View
4 EHC/src/ehc/GrinCode/Trf/LateInline.cag
@@ -89,6 +89,7 @@ SEM GrExpr
( Map.lookup (getNr @nm) @lhs.finalInfo )
+
-- drop the inlined bindings
{-
@@ -113,6 +114,9 @@ SEM GrBind
then GrBind_Arity @nm (length @argNmL)
else @loc.grTrf
+
+
+
%%]
View
31 EHC/src/ehc/GrinCode/Trf/LowerGrin.cag
@@ -26,12 +26,13 @@ WRAPPER GrAGItf
%%[(8 codegen grin) hs module {%{EH}GrinCode.Trf.LowerGrin} import({%{EH}Base.Common}, {%{EH}GrinCode.Common}, qualified Data.Set as Set, qualified Data.Map as Map, Data.List, Data.Monoid, Data.Maybe, {%{EH}GrinCode}) export(lowerGrin)
-lowerGrin :: (GrModule,HptMap) -> (GrModule,HptMap)
+lowerGrin :: (GrModule,HptMap) -> (GrModule,TagMap,HptMap)
lowerGrin (input,hptMap)
= let inh = Inh_GrAGItf {hptMap_Inh_GrAGItf=hptMap}
syn = wrap_GrAGItf (sem_GrAGItf (GrAGItf_AGItf input)) inh
- in (grTrf_Syn_GrAGItf syn, hptMap_Syn_GrAGItf syn)
+ in (grTrf_Syn_GrAGItf syn, tagMap_Syn_GrAGItf syn, hptMap_Syn_GrAGItf syn)
+type TagMap = Map.Map GrTag GrTag
%%]
%%[(8 codegen grin)
@@ -45,6 +46,8 @@ ATTR GrPatLam
GrModule [ | | newItems USE {++} {[]} : HptItems ]
ATTR GrAGItf [ | | hptMap: HptMap ]
+ATTR AllNT GrAGItf [ | | tagMap USE {`Map.union`} {Map.empty} : {TagMap} ]
+
ATTR GrAGItf
GrModule
AllBind
@@ -220,6 +223,7 @@ SEM GrExpr
FetchField
UpdateUnit
Eval
+ FetchVar
Throw loc . newName = maybe @nm
-- (\(GrVal_Var nm) -> nm)
(\v -> case v of (GrVal_Var nm) -> nm
@@ -228,9 +232,32 @@ SEM GrExpr
(Map.lookup @nm @lhs.subst)
| FetchNode lhs . grTrf = GrExpr_FetchNode @newName
| FetchField lhs . grTrf = GrExpr_FetchField @newName @offset @mbTag
+ | FetchVar lhs . grTrf = GrExpr_FetchVar @newName @varos.grTrf
| UpdateUnit lhs . grTrf = GrExpr_UpdateUnit @newName @val.grTrf
| Eval lhs . grTrf = GrExpr_Eval @newName
| Throw lhs . grTrf = GrExpr_Throw @newName
+
+
+-- this is necessary for meta-closures
+
+ATTR GrTag GrVarOffset GrVarOffsetL [ | | self : SELF ]
+
+SEM GrTag
+ | Meta lhs . tagMap = if @loc.self == @loc.grTrf
+ then Map.empty
+ else Map.singleton @loc.self @loc.grTrf
+
+SEM GrVarOffset
+ | GrVarOffset lhs . grTrf = GrVarOffset_GrVarOffset
+ @inFrameOf
+ $ maybe @var
+ -- (\(GrVal_Var nm) -> nm)
+ (\v -> case v of (GrVal_Var nm) -> nm
+ _ -> error $ "LowerGrin: not a GrVal_Var: " ++ show v ++ " as replacement of " ++ show @var
+ )
+ (Map.lookup @var @lhs.subst)
+
+
%%]
View
4 EHC/src/ehc/GrinCode/Trf/NumberIdents.cag
@@ -239,7 +239,11 @@ SEM GrExpr
SEM GrTag
| Con lhs . grTrf = GrTag_Con @grtgAnn @int @nm
| Fun lhs . grTrf = GrTag_Fun (findNewVar @lhs.bindMap @nm)
+ | Meta lhs . grTrf = GrTag_Meta (findNewVar @lhs.bindMap @nm) @args.grTrf
| PApp lhs . grTrf = GrTag_PApp @needs (findNewVar @lhs.bindMap @nm)
| App lhs . grTrf = GrTag_App (findNewVar @lhs.bindMap @nm)
+SEM GrVarOffset
+ | GrVarOffset lhs . grTrf = GrVarOffset_GrVarOffset (findNewVar @lhs.bindMap @inFrameOf) (findNewVar @lhs.bindMap @var)
+
%%]
View
2  EHC/src/ehc/GrinCode/Trf/SetGrinInvariant.cag
@@ -92,7 +92,7 @@ SEM GrExpr
ATTR AllGrVal
- GrTag [ | | ptrOnly : SELF ]
+ GrTag AllGrVarOffset [ | | ptrOnly : SELF ]
SEM GrVal
| Var lhs.ptrOnly = maybe (GrVal_Var @nm)
View
2  EHC/src/ehc/GrinCode/Trf/SpecConst.cag
@@ -37,7 +37,7 @@ ATTR AllNT [ | | grTrf: SELF ]
-- collect global constants
-ATTR AllGrVal AllGrTag [ | | copy: SELF ]
+ATTR AllGrVal AllGrTag AllGrVarOffset [ | | copy: SELF ]
ATTR AllGlobal [ | | genconstMap USE {`Map.union`} {Map.empty} : {Map.Map HsName GrVal} ]
View
35 EHC/src/ehc/GrinCode/Trf/SplitFetch.cag
@@ -59,14 +59,14 @@ WRAPPER GrAGItf
%%[(8 codegen grin) hs module {%{EH}GrinCode.Trf.SplitFetch} import({%{EH}Base.Common}, {%{EH}GrinCode.Common}, {%{EH}GrinCode}) export(splitFetch)
-splitFetch :: (GrModule,HptMap) -> (GrModule,HptMap)
+splitFetch :: (GrModule,HptMap) -> (GrModule,TagMap,HptMap)
splitFetch (input,hptMap)
= let inh = Inh_GrAGItf {hptMap_Inh_GrAGItf=hptMap}
syn = wrap_GrAGItf (sem_GrAGItf (GrAGItf_AGItf input)) inh
- in (grTrf_Syn_GrAGItf syn, hptMap_Syn_GrAGItf syn)
+ in (grTrf_Syn_GrAGItf syn, tagMap_Syn_GrAGItf syn, hptMap_Syn_GrAGItf syn)
type HptItems = [ (Int,AbstractValue) ]
-
+type TagMap = Map.Map GrTag GrTag
%%]
@@ -93,9 +93,10 @@ ATTR GrModule
AllGrPat [ | uniq : Int | ]
-- strange: uniq is not really needed in AllGrVal and AllGrPat, but if they are omitted we get a induced mutal dependency problem with renameMap
-ATTR AllGrExpr
- AllGrVal
- AllGrPat [ renameMap: RenMap | | ]
+ATTR AllExpr [ renameMap: RenMap | | ]
+
+ATTR AllNT GrAGItf [ | | tagMap USE {`Map.union`} {Map.empty} : {TagMap} ]
+
SEM GrAGItf
| AGItf module . uniq = getEnvSize @lhs.hptMap
@@ -143,7 +144,7 @@ SEM GrVar
| Ignore Var lhs. mbTag = Nothing
-ATTR AllGrTag GrVarL GrVar [ | | self:SELF ]
+ATTR AllGrTag GrVarL GrVar AllGrVarOffset [ | | self:SELF ]
SEM GrExpr [ | | fetchPointer: {Maybe HsName} ]
| FetchNode lhs . fetchPointer = Just @nm -- Just (Map.findWithDefault @nm (getNr @nm) @lhs.renameMap)
@@ -263,6 +264,18 @@ SEM GrAlt
++ @expr.newItems
lhs . grTrf = GrAlt_Alt @ann @pat.grTrf (buildSeqs @expr.grTrf @newExprInfo)
+
+-- this is needed for updating tags an variable offsets globally
+
+SEM GrTag
+ | Meta lhs . tagMap = if @loc.self == @loc.grTrf
+ then Map.empty
+ else Map.singleton @loc.self @loc.grTrf
+
+SEM GrVarOffset
+ | GrVarOffset lhs . grTrf = GrVarOffset_GrVarOffset @inFrameOf $ Map.findWithDefault @var (getNr @var) @lhs.renameMap
+
+
%%]
%%[(8 codegen grin).lastFetch
@@ -282,7 +295,7 @@ SEM GrExpr
SEM GrExpr
| Catch loc . hasNext = False
- | FetchNode FetchField
+ | FetchNode FetchField
(loc.uniq
,lhs.newItems
,lhs.grTrf) = if not @lhs.hasNext
@@ -308,13 +321,16 @@ SEM GrVal
| Var lhs . grTrf = maybe @grTrf GrVal_Var (Map.lookup (getNr @nm) @lhs.renameMap)
SEM GrExpr
- | FetchNode FetchField Eval Throw UpdateUnit
+ | FetchNode FetchField FetchVar Eval Throw UpdateUnit
loc . newName = Map.findWithDefault @nm (getNr @nm) @lhs.renameMap
| FetchNode loc . grTrf = GrExpr_FetchNode @newName
| FetchField loc . grTrf = GrExpr_FetchField @newName @offset @mbTag
+ | FetchVar loc . grTrf = trace "updated fetchvar" $ GrExpr_FetchVar @newName @varos.grTrf
| UpdateUnit loc . grTrf = GrExpr_UpdateUnit @newName @val.grTrf
| Eval loc . grTrf = GrExpr_Eval @newName
| Throw loc . grTrf = GrExpr_Throw @newName
+
+
%%]
%%[(8 codegen grin) hs import(qualified Data.Map as Map, Data.Maybe, Data.List)
@@ -396,6 +412,7 @@ tagArity :: GrTag -> Map.Map Int Int -> Int
tagArity (GrTag_Fun nm) arityMap = maybe (error ("Fun " ++ show nm ++ "not in aritymap " ++ show arityMap)) id (Map.lookup (getNr nm) arityMap)
tagArity (GrTag_App nm) arityMap = maybe (error ("App " ++ show nm ++ "not in aritymap " ++ show arityMap)) id (Map.lookup (getNr nm) arityMap)
tagArity (GrTag_PApp n nm) arityMap = maybe (error ("Pap " ++ show nm ++ "not in aritymap " ++ show arityMap)) (\x->x-n) (Map.lookup (getNr nm) arityMap)
+tagArity (GrTag_Meta _ _) _ = 1 -- meta-closure always have 1 argument: the pointer to the frame
tagArity (GrTag_Con ann _ nm) _ = gtannArity ann
tagArity GrTag_Unboxed _ = 1
tagArity GrTag_Hole _ = 0
View
4 EHC/src/ehc/GrinCode/Trf/SubstExpr.cag
@@ -24,6 +24,7 @@ substExpr env expr = let t = wrap_GrExpr (sem_GrExpr expr)
%%[(8 codegen grin)
ATTR AllExpr [ env : Env | | grTrf: SELF ]
+ATTR AllGrVarOffset [ | | self : SELF ]
%%]
@@ -50,11 +51,12 @@ SEM GrVar
| Var lhs . grTrf = GrVar_Var (findNewVar @lhs.env @nm)
SEM GrExpr
- | App Eval FetchNode FetchField Throw UpdateUnit
+ | App Eval FetchNode FetchField Throw UpdateUnit FetchVar
loc . newName = findNewVar @lhs.env @nm
| App lhs . grTrf = GrExpr_App @newName @argL.grTrf
| Eval lhs . grTrf = GrExpr_Eval @newName
| FetchNode lhs . grTrf = GrExpr_FetchNode @newName
+ | FetchVar lhs . grTrf = GrExpr_FetchVar @newName @varos.self
| FetchField lhs . grTrf = GrExpr_FetchField @newName @offset @mbTag
| UpdateUnit lhs . grTrf = GrExpr_UpdateUnit @newName @val.grTrf
| FetchUpdate lhs . grTrf = GrExpr_FetchUpdate (findNewVar @lhs.env @src) (findNewVar @lhs.env @dst)
View
67 EHC/src/ehc/GrinCode/Trf/SubstMeta.cag
@@ -0,0 +1,67 @@
+%%[doesWhat doclatex
+
+This transformation substitutes meta-tags globally. Also the corresponding VarOffsets are substituted.
+
+The meta-tags in HPT table are also substituted
+
+Currently run after SplitFetch and LowerGrin, if meta-closures are enabled.
+%%]
+
+%%[(8 codegen grin) ag import({GrinCode/AbsSyn})
+%%]
+%%[(8 codegen grin) hs import(qualified Data.Set as Set)
+%%]
+%%[(8 codegen grin) hs import(qualified Data.Array as Array)
+%%]
+%%[(8 codegen grin) hs import(Debug.Trace)
+%%]
+
+%%[(8 codegen grin)
+WRAPPER GrAGItf
+%%]
+
+%%[(8 codegen grin) hs module {%{EH}GrinCode.Trf.SubstMeta} import(qualified Data.Map as Map, {%{EH}GrinCode.Common}, {%{EH}Base.Common}, {%{EH}GrinCode}) export(substMeta,TagMap)
+
+type TagMap = Map.Map GrTag GrTag
+type OffsetMap = Map.Map GrVarOffset GrVarOffset
+
+substMeta :: TagMap -> (GrModule, HptMap) -> (GrModule, HptMap)
+substMeta tagmap (input,hpt)= let inh = Inh_GrAGItf {tagMap_Inh_GrAGItf=tagmap}
+ syn = wrap_GrAGItf (sem_GrAGItf (GrAGItf_AGItf input)) inh
+ in (grTrf_Syn_GrAGItf syn, substMetaHpt tagmap hpt)
+
+substMetaHpt tagmap hpt =
+ Array.array (Array.bounds hpt) $ map (\(i,e) -> (i,substTags e)) (Array.assocs hpt)
+ where
+ substTags (AbsTags tagSet) = AbsTags $ Set.map substTag tagSet
+ substTags (AbsUnion map) = AbsUnion $ Map.map substTags $ Map.mapKeys substTag map
+ substTags (AbsNodes (Nodes map)) = AbsNodes $ Nodes $ Map.mapKeys substTag map
+ substTags a = a
+ substTag tag = Map.findWithDefault tag tag tagmap
+
+%%]
+
+%%[(8 codegen grin)
+ATTR AllNT [ tagMap : {TagMap} | | grTrf: SELF ]
+ATTR GrAGItf [ tagMap : {TagMap} | | grTrf: GrModule ]
+ATTR GrTag AllGrVarOffset [ | | self : SELF ]
+
+ATTR GrTag GrPatAlt [ | | offsetMapUp USE {`Map.union`} {Map.empty} : {OffsetMap} ]
+ATTR AllNT [ offsetMap : {OffsetMap} | | ]
+
+SEM GrAGItf
+ | AGItf module . offsetMap = Map.empty
+
+SEM GrTag
+ | Meta lhs . (offsetMapUp, grTrf) = let makeOffsetMap (GrTag_Meta _ args) = Map.fromList $ zip @args.self args
+ in case Map.lookup @loc.self @lhs.tagMap of
+ Nothing -> (Map.empty , @loc.self )
+ Just newTag -> (makeOffsetMap newTag, newTag )
+
+SEM GrAlt
+ | Alt expr . offsetMap = Map.union @pat.offsetMapUp @lhs.offsetMap -- Map.union prefers left
+
+SEM GrVarOffset
+ | GrVarOffset lhs . grTrf = Map.findWithDefault @loc.self @loc.self @lhs.offsetMap
+
+%%]
View
2  EHC/src/ehc/Silly.cag
@@ -10,7 +10,7 @@
%%[(8 codegen grin) hs module {%{EH}Silly} import ({%{EH}GrinCode.Common} hiding (Variable(..)))
%%]
-%%[(8 codegen grin) hs export(SilModule(..), Function(..), Statement(..), Alternative(..), Constant(..), Variable(..), Value(..), Alternatives, Statements, Functions, Values )
+%%[(8 codegen grin) hs export(SilModule(..), Function(..), Statement(..), Alternative(..), Constant(..), Variable(..), Value(..), Alternatives, Statements, Functions, Values )
%%]
%%[(8 codegen grin) hs export(SillyAllocManageType(..))
%%]
View
11 EHC/src/ehc/Silly/AbsSyn.cag
@@ -42,7 +42,7 @@ DATA Statement
tailJumps : {Bool}
args : Values
| Return vals : Values
- mbRetDiff : {Maybe Int}
+ retAddrLoc : Value
| Label name : {String}
| Comment comment : {[String]}
| Voiden val : Value
@@ -67,6 +67,7 @@ DATA Variable
index : {Int}
| LP
| SP
+ | SPTemp
| RP
| Aux
| Ptr
@@ -77,6 +78,8 @@ DATA Value
| Var var : Variable
| Offset var : Variable
off : {Int}
+ | OffsetVar frame : Variable
+ var : {HsName}
| Cast val : Value
word : {Bool}
| Alloc size : {Int}
@@ -86,9 +89,13 @@ DATA Value
args : Values
| CompareGT val : Value
con : Constant
+ | Dereference val : Value -- waarom ? gebruik subs 0?
+ | This
+ | None
+
-SET AllNT = SilModule Functions Function Statements Statement Alternatives Alternative Constant Variable Values Value
+SET AllNT = SilModule Functions Function Statements Statement Alternatives Alternative Constant Variable Values Value
DERIVING * : Show, Ord
View
19 EHC/src/ehc/Silly/ElimUnused.cag
@@ -23,6 +23,10 @@ WRAPPER SilModule
%%[(8 codegen grin) hs import(qualified Data.Set as Set)
%%]
+%%[(8 codegen grin)
+PRAGMA nocycle
+%%]
+
%%[(8 codegen grin) hs
elimUnused :: EHCOpts -> SilModule -> SilModule
elimUnused options input
@@ -43,6 +47,17 @@ ATTR AllNT [ | | trf: SELF ]
--
ATTR AllNT [ | | self: SELF ]
+-- all variables that are used in an offset var context
+ATTR AllNT [ | | offsetVars USE {`Set.union`} {Set.empty}: {Set.Set HsName} ]
+ATTR Functions Function Statements Statement Alternatives Alternative Constant Variable Values Value
+ [ allOffsetVars : {Set.Set HsName} | | ]
+
+SEM Value
+ | OffsetVar lhs.offsetVars = Set.singleton @var
+
+
+SEM SilModule
+ | SilModule functions.allOffsetVars = @functions.offsetVars
ATTR Variable [ multi : {Int} | | ]
ATTR Statement Statements Alternative Alternatives Variable Value Values [ | useMap : {Map.Map Variable Int} | ]
@@ -54,7 +69,8 @@ ATTR Value [ | | isntCall : {Bool} ]
SEM Function
| Function body.useMap = @loc.startMap
body.allUseMap = @body.useMap
- loc.startMap = Map.fromList [ (Variable_Unembedded nm, 0) | nm <- @locals ]
+ loc.startMap = let startValue nm = if nm `Set.member` @lhs.allOffsetVars then 1 else 0
+ in Map.fromList [ (Variable_Unembedded nm, startValue nm) | nm <- @locals ]
-- the "multi" attribute is a bit of a hack:
-- it makes variables in a Subs context count as a "use"
@@ -62,6 +78,7 @@ SEM Function
SEM Value
| Var var.multi = 1
| Offset var.multi = 1
+ | OffsetVar frame.multi = 1
SEM Variable
| Subs array.multi = 1
View
289 EHC/src/ehc/Silly/EmbedVars.cag
@@ -1,3 +1,5 @@
+-- kate: indent-mode normal
+
%%[0
%include lhs2TeX.fmt
%include afp.fmt
@@ -35,20 +37,23 @@ embedVars :: EHCOpts -> SilModule -> SilModule
embedVars options input
= let t = wrap_SilModule (sem_SilModule input)
(Inh_SilModule {opts_Inh_SilModule = options})
- in trf_Syn_SilModule t
+ in if (ehcOptMetaClosures options)
+ then trfMeta_Syn_SilModule t
+ else trf_Syn_SilModule t
+
%%]
%%[(8 codegen grin)
ATTR SilModule [ opts : {EHCOpts} | | ]
-ATTR AllNT [ | | trf: SELF ]
+ATTR AllNT [ | | trf: SELF ]
ATTR Statement Statements Alternative Alternatives Variable Value Values [ numberLocals : {Int} | | ]
ATTR Statement Statements Alternative Alternatives [ | embedMap : {EmbedMap} | ]
ATTR Variable Value Values [ embedMap : {EmbedMap} | | ]
ATTR Statement Statements Alternative Alternatives Variable [ | | localsSet USE {`Set.union`} {Set.empty}: {Set.Set HsName} ]
ATTR Statement Statements Alternative Alternatives Variable Value Values [ | | usedSet USE {`Set.union`} {Set.empty}: {Set.Set HsName} ]
ATTR Statement Statements Alternative Alternatives [ neededSet: {Set.Set HsName} | | ]
-ATTR Statement Statements Alternative Alternatives [ numberParameters : {Int} | | ]
+ATTR Statement Statements Alternative Alternatives Variable Value Values [ numberParameters : {Int} | | ]
ATTR Statement [ | | trfStats: {[Statement]} ]
ATTR Function Functions
Statement Statements Alternative Alternatives Value Values Variable [ optGenOwn : {Bool} optGenLink : {Bool} optGenLocReg : {Bool}| | ]
@@ -99,7 +104,7 @@ SEM Statement
:
smartAssignment (zip destinations sources) -- do stack-putting in an overlapping fashion with the original stack contents
++
- [ Statement_Assignment Variable_SP (Value_Offset Variable_SP adjust) -- adjust stack: increment for original parameters&callinfo&locals, decrement for new parameters&callinfo
+ [ Statement_Assignment Variable_SP (Value_Offset Variable_SP adjust) -- adjust stack: increment for original parameters&callinfo&locals, decrement for new parameters&callinfo
| adjust /= 0 -- (if necessary)
]
++
@@ -119,7 +124,7 @@ SEM Statement
)
++ reverse @args.trf -- put arguments on stack
++ [ Value_Label @loc.label ] -- put return address on the stack
- ++ [ Value_Cast (Value_Offset Variable_SP nl) True -- put dynamic link on the stack
+ ++ [ Value_Cast (Value_Offset Variable_SP nl) True -- put dynamic link on the stack
| @lhs.optGenLink -- (if requested)
]
destinations = (map (Variable_Subs Variable_SP) (iterate decrement (-1)))
@@ -128,13 +133,13 @@ SEM Statement
:
zipWith Statement_Assignment destinations sources -- do stack-putting by assignments
++
- [ Statement_Assignment Variable_SP (Value_Offset Variable_SP adjust) -- adjust stack: decrement for new parameters&callinfo
+ [ Statement_Assignment Variable_SP (Value_Offset Variable_SP adjust) -- adjust stack: decrement for new parameters&callinfo
, Statement_Call @name False [] -- do the call (in fact a jump, which will return one line below here)
, Statement_Label @loc.label -- return here after the call
]
++
( if @lhs.optGenLocReg
- then Statement_Assignment Variable_SP (Value_Offset Variable_SP (length registersToSave))
+ then Statement_Assignment Variable_SP (Value_Offset Variable_SP (length registersToSave))
:
zipWith Statement_Assignment registersToSave (map Value_Var destinations) -- restore registers
else []
@@ -163,8 +168,8 @@ SEM Statement
( if @lhs.optGenOwn
then let n | @lhs.optGenReturnViaStack = max @vals.length @lhs.numberParameters
| otherwise = @lhs.numberParameters
- in [ Statement_Assignment Variable_SP (Value_Offset Variable_SP (locPar + callInfoSize ))
- , Statement_Return [] (Just (n + 1 ))
+ in [ Statement_Assignment Variable_SP (Value_Offset Variable_SP (locPar + callInfoSize ))
+ , Statement_Return [] (Value_Var $ Variable_Subs Variable_SP (-(n + 1 )))
]
else []
)
@@ -189,7 +194,7 @@ SEM Function
then Statement_Comment ["Expects " ++ show (length @parameters) ++ " parameters, uses " ++ show @loc.numberLocals ++ " local variables" ]
: ( if @lhs.optGenLocReg || @loc.numberLocals == 0
then []
- else [ Statement_Assignment Variable_SP (Value_Offset Variable_SP (- @loc.numberLocals)) ]
+ else [ Statement_Assignment Variable_SP (Value_Offset Variable_SP (- @loc.numberLocals)) ]
)
else []
)
@@ -199,6 +204,7 @@ SEM Function
SEM Function
| Function body . numberParameters = length @parameters
body . embedMap = Map.fromList (zipWith (makeEmbedTupel Variable_Param) [1..] @parameters)
+ loc . numberLocals : Int
loc . numberLocals = maxNeededLocal @body.localsSet @body.embedMap
@@ -223,13 +229,13 @@ SEM Statement
{
maxNeededLocal :: Set.Set HsName -> EmbedMap -> Int
maxNeededLocal s m = let ns = [ n | Variable_Local n v <- Map.elems m , Set.member v s ]
- in if null ns then 0 else maximum ns
+ in {- trace (show $ Set.toList s) $ -} if null ns then 0 else maximum ns
}
SEM Function
- | Function body . neededSet = Set.empty
+ | Function body . neededSet = @lhs.persistentVars
SEM Statements
| Cons hd . neededSet = Set.union @lhs.neededSet @tl.usedSet
@@ -258,6 +264,25 @@ SEM Variable
@lhs.embedMap
@name
+-- The needed set is the set of variables that is still used later on the function
+-- this is used to re-use memory location for different variables
+-- For meta-closures however a variable might still be used, even though it is never
+-- referenced again in the function, it might be looked up later on
+-- through a variable offset (fetch var). To make sure
+-- that these variables aren't overwritten we first built the set
+-- of "persistent" variables, i.e. variables that should have
+-- their own memory location.
+-- This is added to the needed set.
+
+ATTR Functions Function Statements Statement Alternatives Alternative Constant Variable Values Value
+ [ persistentVars : {Set.Set HsName} | | persistentVarsUp USE {`Set.union`} {Set.empty} : {Set.Set HsName} ]
+
+SEM Value
+ | OffsetVar lhs.persistentVarsUp = Set.singleton @var
+
+SEM SilModule
+ | SilModule functions.persistentVars = @functions.persistentVarsUp
+
%%]
@@ -285,9 +310,11 @@ strategyLocReg :: Int -> Int -> EmbedStrategy
strategyLocReg d _ (Variable_Local n _) = Variable_Subs Variable_LP n
strategyLocReg d callInfoSize (Variable_Param n _) = Variable_Subs Variable_SP (callInfoSize-1+n)
+-- new for meta closures
-
-
+strategyOnHeapFrame :: Int -> EmbedStrategy
+strategyOnHeapFrame nrParams (Variable_Local n _) = Variable_Subs Variable_SP (2 + nrParams + n -1 )
+strategyOnHeapFrame _ (Variable_Param n _) = Variable_Subs Variable_SP (2+n -1 )
embedUsing :: EmbedStrategy -> EmbedMap -> EmbedFunction
embedUsing strat m x@(HNmNr n _) = if n==0
@@ -305,6 +332,8 @@ postPad n s = let w = length s
in if w>=n then s else s ++ replicate (n-w) ' '
+
+
%%]
@@ -406,3 +435,235 @@ smartChain v (SmartTree (Left root) kids, mbindex)
%%]
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%%% Embedding of parameters and local variables in frames on the heap for Meta closures (new) by Atze van der Ploeg
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%%[(8 codegen grin)
+
+
+
+-- compute frame sizes (new)
+
+ATTR AllNT [ | | frameSizesMapUp USE {`Map.union`} {Map.empty} : {Map.Map HsName Int} ]
+
+SEM Function
+ | Function lhs.frameSizesMapUp = let callInfoSize = 2 -- 1 for return adress, 1 for dynamic link
+ size = (@loc.numberLocals) + (length @parameters) + callInfoSize
+ in Map.singleton @name size
+
+ATTR Functions Function Statements Statement Alternatives Alternative [ frameSizesMap : {Map.Map HsName Int} || ]
+
+-- reinsert result of up into top of tree
+
+SEM SilModule
+ | SilModule functions.frameSizesMap = @functions.frameSizesMapUp
+
+{- Here we use a different frame layout:
+
+0: ret addr
+1: dyn link
+2: argument 1
+3: argument 2
+.
+.
+n + 2 : argument n
+n + 3 : local variable 1
+n + 4 : local variable 2
+.
+.
+n + m + 2 : local variable m
+
+-}
+
+
+-- ATTR Function Statement Statements Alternative Alternatives Value Values Variable
+-- [ | | realNrLocals USE {+} {0}: {Int} ]
+--
+-- -- get the set of locals that is actually used, apperantly the list of @locals of a function is not updated in the last transform...
+--
+-- SEM Variable
+-- | Unembedded lhs . realNrLocals = case @name of
+-- HNmNr _ (OrigGlobal _) -> 0 -- apperantly if we can somehow see if it was originally a global
+-- _ -> 1
+
+-- now make a map from the name of a variable to its position in the frame
+
+-- SEM Function
+-- | Function body.mEmbedMap =
+-- let keyValuePairs = zip allNames [callInfoSize..]
+-- allNames = @parameters ++ (Set.toList @body.realLocals)
+-- callInfoSize = 2
+-- in Map.fromList keyValuePairs
+
+-- the actual transformation
+
+ATTR AllNT [ | | trfMeta : SELF ]
+
+ATTR Statement [ | | trfMetaStats: {[Statement]} ]
+SEM Statement
+ | Call lhs.trfMetaStats
+ = let allocFrame =
+ [Statement_Comment ["Going to call", "Allocate new heap frame"],
+ Statement_Assignment Variable_SPTemp newFramePointer]
+ where newFramePointer = Value_Cast (Value_Alloc allocFrameSize GCManaged) False -- for obscure reason heapmalloc returns a word!
+ Just allocFrameSize = Map.lookup @name @lhs.frameSizesMap
+
+ fillArgumentsAndCallinfoInFrame =
+ Statement_Comment ["Fill in arguments and params"] :
+ zipWith Statement_Assignment destinations sources
+ where
+ sources =
+ returnAddress ++
+ dynamicLink ++
+ arguments
+
+ returnAddress = [ Value_Label @loc.label ]
+ dynamicLink = [ Value_Cast (Value_Var Variable_SP) True ]
+ arguments = @args.trfMeta
+ destinations = map (Variable_Subs Variable_SPTemp) [0..]
+
+ switchSP = [ Statement_Comment ["Switching SP to new frame"],
+ Statement_Assignment Variable_SP $ Value_Var Variable_SPTemp ]
+
+ jump = [ Statement_Call @name False [] ]
+
+ label = [ Statement_Label @loc.label ]
+
+ returnIfTailCall =
+ if @tailJumps
+ then jumpBackImmediatly
+ else []
+ where
+ jumpBackImmediatly =
+ -- these are defined below
+ saveOldFramePtr ++
+ restoreDynamicLink ++
+ jumpToReturnAdress
+
+
+ in allocFrame ++
+ fillArgumentsAndCallinfoInFrame ++
+ switchSP ++
+ jump ++
+ label ++
+ returnIfTailCall
+
+
+
+ | Return lhs.trfMetaStats
+ = let setReturnValues =
+ Statement_Comment ["set return values"] :
+ zipWith Statement_Assignment destinations sources
+ where sources = @vals.trfMeta
+ destinations = map returnRegister [0..]
+ returnRegister i = Variable_Subs Variable_RP i
+ -- for the last three see below
+ in setReturnValues ++
+ saveOldFramePtr ++
+ restoreDynamicLink ++
+ jumpToReturnAdress
+
+
+
+
+
+ | * - Return
+ Call lhs . trfMetaStats = [@loc.trfMeta]
+
+SEM Statements
+ | Cons lhs . trfMeta = @hd.trfMetaStats ++ @tl.trfMeta
+
+
+-- a problem with frames on the heap is that we need to know the size of the frame of the function before
+-- calling it. This gives us a problem when translating to C, we must call the main silly function from c
+-- but we do not know how big the frame of main is. To get around this we let c alloc a frame of size 2 for main,
+-- and then let main alloc the actual frame and copy the data (dynamic link, return adress) from the original frame.
+
+SEM Function
+ | Function lhs.trfMeta
+ = Function_Function
+ @name
+ [] -- no parameters
+ [] -- no locals
+ ( if hsnShowAlphanumeric @name == "fun_fun0tildemain"
+ then let frameSize = Map.findWithDefault (error "cannot find size of main!") @name @lhs.frameSizesMap
+ in (makeMainFrame frameSize ) ++ @body.trfMeta
+ else @body.trfMeta
+ )
+
+{
+
+makeMainFrame frameSize = [ Statement_Assignment Variable_SPTemp ( Value_Cast (Value_Alloc frameSize GCManaged) False )
+ , Statement_Assignment (Variable_Subs Variable_SPTemp 0) (Value_Var $ Variable_Subs Variable_SP 0)
+ , Statement_Assignment (Variable_Subs Variable_SPTemp 1) (Value_Var $ Variable_Subs Variable_SP 1)
+ , Statement_Assignment (Variable_SP) (Value_Var Variable_SPTemp)
+ ]
+}
+
+SEM Variable
+ | Unembedded lhs.trfMeta = embedUsing ( strategyOnHeapFrame @lhs.numberParameters )
+ @lhs.embedMap
+ @name
+
+SEM Value
+ | This lhs.trfMeta = Value_Cast (Value_Var Variable_SP) True
+
+ATTR Variable [ | | self : SELF ]
+
+SEM Value
+ | OffsetVar lhs.trfMeta = let (HNmNr nameNr _) = @var -- note that we use here that nrs are globally unique
+ offset = case Map.lookup nameNr @lhs.frameOffsetMap of
+ Just off -> off
+ Nothing -> error $ "No offset found in map for var with nr:" ++ (show nameNr)
+ in Value_Var $ Variable_Subs @frame.trfMeta offset
+
+-- get the offsets of all local variables and parameters
+ATTR Functions Function Statements Statement Alternatives Alternative Constant Variable Values Value [frameOffsetMap : {Map.Map Int Int} | | frameOffsetMapUp USE {`Map.union`} {Map.empty} : {Map.Map Int Int} ]
+
+SEM SilModule
+ | SilModule functions.frameOffsetMap = @functions.frameOffsetMapUp
+--
+SEM Function
+ | Function lhs.frameOffsetMapUp = let embed x = embedUsing ( strategyOnHeapFrame (length @parameters) )
+ @body.embedMap
+ x
+ offset embedded = case embedded of
+ Variable_Subs Variable_SP offset -> offset
+ _ -> error "No offset found"
+ allVars = @parameters ++ @locals
+ offsets = map (offset . embed) allVars
+ nameNr x = case x of
+ (HNmNr nameNr _) -> nameNr
+ _ -> error "encountered non nr name when constucting frame offset map"
+ nameNrs = map nameNr allVars
+ in Map.fromList $ zip nameNrs offsets
+
+
+{
+-- shared between call and return
+saveOldFramePtr =
+ [ Statement_Comment ["save old frame pointer"] ,
+ Statement_Assignment Variable_Aux $ Value_Dereference $ Value_Var Variable_SP ]
+
+restoreDynamicLink =
+ [ Statement_Comment ["restoring dynamic link"],
+ Statement_Assignment Variable_SP dynamicLinkLocation ]
+ where dynamicLinkLocation =
+ Value_Cast (Value_Var $ Variable_Subs Variable_SP dynlinkoffset) False
+ dynlinkoffset = 1
+
+jumpToReturnAdress =
+ [ Statement_Return [] returnAdressLocation ]
+ where returnAdressLocation = Value_Var Variable_Aux
+
+}
+
+
+
+
+
+
+
+%%]
View
7 EHC/src/ehc/Silly/GroupAllocs.cag
@@ -2,6 +2,8 @@
%% Group together the allocations in a list of statements
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%
+%% This transformation is obsolete and disabled...
+%%
%% In silly, often trees of closures are created. This results in code as
%% follows:
%%
@@ -57,11 +59,12 @@ groupAllocs :: EHCOpts -> SilModule -> SilModule
groupAllocs options input
= let t = wrap_SilModule (sem_SilModule input)
(Inh_SilModule {})
- in trf_Syn_SilModule t
+ in input -- trf_Syn_SilModule t
%%]
%%[(8 codegen grin)
+{-
-- Result of the AG transformation.
ATTR AllNT [ | | trf: SELF ]
@@ -128,4 +131,6 @@ SEM Statement
@source.allocWordCount
then Just @dest.trf
else @lhs.ptrToAlloc
+
+-}
%%]
View
48 EHC/src/ehc/Silly/InlineExpr.cag
@@ -82,6 +82,7 @@ SEM Variable
SEM Value
| Var var.multi = 1
| Offset var.multi = 2
+ | OffsetVar frame.multi = 2
SEM Variable
| Subs array.multi = 2
@@ -110,10 +111,43 @@ SEM Statement
then Map.insert @dest.self @source.trf env2
else env2
--- In each Call-statement, remove the environment-entries of which the RHS uses the RP-register or a negative offset from SP
+-- After each Call-statement, remove the environment-entries of which the RHS uses the RP-register or a negative offset from SP
SEM Statement
| Call lhs.env = Map.filter (not . isRPValue) @lhs.env
+
+
+-- Within the values of a Return-statement, remove all the environment-entries of which the RHS uses a RP-register
+
+-- SEM Statement
+-- | Return vals.env = Map.filter (not . isRPValue) @lhs.env
+
+
+-- Within the values of a Return-statement, remove the environment-entries of which the RHS uses a lower RP-register than the current sequence number
+
+ATTR Value Values [ mbSeqNr : {Maybe Int} | | ]
+
+SEM Values
+ | Cons tl.mbSeqNr = maybe Nothing (\n -> Just (n+1)) @lhs.mbSeqNr
+ hd.env = maybe @lhs.env (\n -> Map.filter (not . isLowRPValue n) @lhs.env) @lhs.mbSeqNr
+
+SEM Statement
+ | Call args.mbSeqNr = Nothing
+ | Assignment
+ Assignment2 source.mbSeqNr = Nothing
+ | IfThenElse condition.mbSeqNr = Nothing
+ | Switch scrutinee.mbSeqNr = Nothing
+ | Voiden val.mbSeqNr = Nothing
+SEM Value
+ | Call args.mbSeqNr = Nothing
+ | Cast
+ CompareGT val.mbSeqNr = Nothing
+
+SEM Statement
+ | Return vals.mbSeqNr = Just 0
+
+
+
-- For variables, do the substitution
@@ -140,6 +174,18 @@ isRPValue :: Value -> Bool
isRPValue (Value_Var var) = isRP var
isRPValue _ = False
+
+isLowRP :: Int -> Variable -> Bool
+isLowRP _ (Variable_RP) = True
+isLowRP k (Variable_Subs var n) = isLowRP k var && n<k
+isLowRP _ _ = False
+
+isLowRPValue :: Int -> Value -> Bool
+isLowRPValue k (Value_Var var) = isLowRP k var
+isLowRPValue _ _ = False
+
+
+
isSimpleVariable :: Variable -> Bool
isSimpleVariable (Variable_Subs Variable_SP _) = True
isSimpleVariable (Variable_Subs _ _) = False
View
15 EHC/src/ehc/Silly/Pretty.cag
@@ -37,7 +37,7 @@ WRAPPER SilModule
%%[(8 codegen grin)
ATTR SilModule [ opts : {EHCOpts} | | ]
-ATTR SilModule Functions Function Statements Statement Alternatives Alternative Value Values Variable Constant
+ATTR SilModule Functions Function Statements Statement Alternatives Alternative Value Values Variable Constant
[ | | pretty USE {>-<} {empty} : PP_Doc ]
@@ -67,7 +67,7 @@ SEM Statement
| Assignment2 lhs.pretty = @dest.pretty >#< ":=" >#< @dest2.pretty >#< ":=" >#< @source.pretty >|< ";"
| Switch lhs.pretty = "SWITCH" >#< @scrutinee.pretty >-< "{" >-< @body.pretty >-< "}"
| IfThenElse lhs.pretty = "IF" >#< @condition.pretty >-< "THEN {" >-< indent 4 @thenpart.pretty >-< "}" >-< "ELSE {" >-< indent 4 @elsepart.pretty >-< "}"
- | Return lhs.pretty = "RETURN (" >#< @vals.pretty >|< ")" >#< text (show @mbRetDiff) >|< ";"
+ | Return lhs.pretty = "RETURN (" >#< @vals.pretty >|< ")" >#< @retAddrLoc.pretty >|< ";"
| Label lhs.pretty = "LABEL" >#< text @name >|< ";"
| Voiden lhs.pretty = "VOIDEN" >#< @val.pretty >|< ";"
%%[[8
@@ -104,8 +104,9 @@ SEM Variable
%%]]
| LP lhs.pretty = text "LP"
| SP lhs.pretty = text "SP"
+ | SPTemp lhs.pretty = text "SPTemp"
| RP lhs.pretty = text "RP"
- | Subs lhs.pretty = @array.pretty >|< "[" >|< show @index >|< "]"
+ | Subs lhs.pretty = @array.pretty >|< "[" ++ show @index ++ "]"
| Aux lhs.pretty = text "AUX"
| Ptr lhs.pretty = text "PTR"
| None lhs.pretty = text "NONE"
@@ -120,14 +121,20 @@ SEM Value
| Alloc lhs.pretty = text "allocate(" >|< show @size >|< ") {" >#< show @gcManaged >#< "}"
| Call lhs.pretty = "foreign" >#< @name >|< "(" >|< @args.pretty >|< ")"
%%]]
- | Offset lhs.pretty = @var.pretty >#< "+" >#< show @off
+ | Offset lhs.pretty = @var.pretty >#< "+" ++ (show @off)
+ | OffsetVar lhs.pretty = @frame.pretty >|< "[" ++ hsnShowAlphanumeric @var ++ "]"
| Label lhs.pretty = text "LABEL" >#< show @name
| CompareGT lhs.pretty = @val.pretty >#< ">" >#< @con.pretty
+ | This lhs.pretty = text "THIS"
SEM Values
| Nil lhs.pretty = empty
| Cons lhs.pretty = @hd.pretty >|< ", " >|< @tl.pretty
+-- SEM OffsetDesc
+-- | Number lhs.pretty = text $ show @n
+-- | Const lhs.pretty = text $ "O/" ++ hsnShowAlphanumeric @function ++ "/" ++ hsnShowAlphanumeric @var
+
%%]
%%[(8 codegen grin) hs
comment :: [String] -> PP_Doc
View
100 EHC/src/ehc/Silly/PrettyC.cag
@@ -50,6 +50,7 @@ SEM SilModule
loc.optCaseDefault = ehcOptGenCaseDefault @lhs.opts
loc.optGenOwn = ehcOptGenOwn @lhs.opts
loc.optGenLink = ehcOptGenOwn @lhs.opts && ehcOptGenLink @lhs.opts
+ loc.optMeta = ehcOptMetaClosures @lhs.opts
%%]
@@ -66,11 +67,12 @@ ATTR Functions Function [ | | protoC USE {>-<} {empty} : {PP_Doc} ]
ATTR Values [ | | prettyCs : {[PP_Doc]} ]
ATTR Values [ | | prettyTXTs : {[PP_Doc]} ]
-ATTR Variable
- Value [ | | prettyPtr : {PP_Doc} ]
+-- ATTR Variable
+ -- Value [ | | prettyPtr : {PP_Doc} ]
ATTR Variable [ | | isSP : {Bool} ]
+ATTR Variable [ | | isPointer : {Bool} ]
ATTR Statements Statement Alternatives Alternative
[ functionname : String | | ]
@@ -90,6 +92,7 @@ SEM SilModule
>-< comment ["Auxiliary variables"]
>-< text "Word auxVar;"
>-< text "Word auxPtr;"
+ >-< text "WPtr SPTemp;"
>-< text ""
>-< comment ["Function definitions"]
>-< (if @loc.optGenOwn
@@ -113,13 +116,14 @@ SEM SilModule
loc.silMain1 = text "int silly_main()"
>-< text "{"
-- >-< ppWhen False (text "register WPtr SP asm (\"%esp\");")
- >-< indent 4 ( callSillyFunctionFromC @loc.optTraceAssign @loc.optGenOwn @loc.optGenLink 1 "initialize"
+ >-< indent 4 ( callSillyFunctionFromC @loc.optTraceAssign @loc.optGenOwn @loc.optGenLink @loc.optMeta 1 "initialize"
%%[[8
- >-< callSillyFunctionFromC @loc.optTraceAssign @loc.optGenOwn @loc.optGenLink 2 "fun_fun0tildemain"
+ >-< callSillyFunctionFromC @loc.optTraceAssign @loc.optGenOwn @loc.optGenLink @loc.optMeta 2 "fun_fun0tildemain"
%%][99
- >-< callSillyFunctionFromC @loc.optTraceAssign @loc.optGenOwn @loc.optGenLink 2 "fun_mainFullProg"
+ >-< callSillyFunctionFromC @loc.optTraceAssign @loc.optGenOwn @loc.optGenLink @loc.optMeta 2 "fun_mainFullProg"
%%]]
- >-< "if (Ret1==0) { Ret0 = SP[-1]; Ret1 = SP[-2]; }"
+ >-< (if not @loc.optMeta then "if (Ret1==0) { Ret0 = SP[-1]; Ret1 = SP[-2]; }" else "")
+ -- >-< "printf(\"Done!!!!!!!!!!!!!\"); fflush(stdout);"
>-< "return 0;"
)
@@ -145,11 +149,12 @@ SEM Function
SEM Statement
| Comment lhs.prettyC = comment @comment
- | Assignment lhs.prettyC = assignment @lhs.optTraceAssign @dest.prettyC (if @dest.isSP then @source.prettyPtr else @source.prettyC) @source.prettyTXT
+ -- | Assignment lhs.prettyC = assignment @lhs.optTraceAssign @dest.prettyC (if @dest.isSP then @source.prettyPtr else @source.prettyC) @source.prettyTXT
+ | Assignment lhs.prettyC = assignment @lhs.optTraceAssign @dest.prettyC @source.prettyC @source.prettyTXT
| Assignment2 lhs.prettyC = assignment2 @lhs.optTraceAssign @dest.prettyC @dest2.prettyC @source.prettyC @source.prettyTXT
| Switch lhs.prettyC = switch @lhs.optTraceAssign @lhs.optCaseDefault @lhs.functionname @scrutinee.prettyC @body.prettyC
| Call lhs.prettyC = callSillyFunctionFromSilly @lhs.optGenOwn (hsnShowAlphanumeric @name) @args.prettyCs
- | Return lhs.prettyC = returnFromSillyFunction @lhs.optTraceAssign (fromJust @mbRetDiff) @lhs.optGenOwn
+ | Return lhs.prettyC = returnFromSillyFunction @lhs.optTraceAssign (@retAddrLoc.prettyC) @lhs.optGenOwn
| Label lhs.prettyC = label @lhs.optTraceCall @name
| Voiden lhs.prettyC = @val.prettyC >|< ";"
| IfThenElse lhs.prettyC = ifthenelse @condition.prettyC
@@ -177,7 +182,8 @@ SEM Values
SEM Value
| Con lhs.prettyC = @con.prettyC
| Var lhs.prettyC = @var.prettyC
- | Offset lhs.prettyC = "(Word)(" >|< @var.prettyPtr >|< "+" ++ show @off ++ ")"
+-- | Offset lhs.prettyC = "(Word)(" >|< @var.prettyC >|< "+" ++ show @off ++ ")"
+ | Offset lhs.prettyC = @var.prettyC >|< "+" ++ show @off
| Cast lhs.prettyC = ("((" ++ (if @word then "Word" else "WPtr") ++ ")(") >|< @val.prettyC >|< "))"
| Call lhs.prettyC = ( maybe (callCfunction @name)
fromSillyPrim
@@ -187,15 +193,15 @@ SEM Value
GCManaged -> "heapalloc(" >|< show @size >|< ")"
| Label lhs.prettyC = "((Word)(&&" >|< @name >|< "))"
| CompareGT lhs.prettyC = @val.prettyC >#< ">" >#< @con.prettyC
+ | Dereference lhs.prettyC = "*(" >|< @val.prettyC >|< ")"
- | Offset lhs.prettyPtr = @var.prettyPtr >|< "+" ++ show @off
- | *-Offset lhs.prettyPtr = error "prettyC: called prettyPtr from non-Offset Value"
SEM Value
| Con lhs.prettyTXT = @con.prettyTXT
| Var lhs.prettyTXT = @var.prettyC
- | Offset lhs.prettyTXT = @var.prettyPtr >|< "+" ++ show @off
+ -- | Offset lhs.prettyTXT = @var.prettyPtr >|< "+" >|< @off.prettyC
+ | Offset lhs.prettyTXT = @var.prettyC >|< "+" ++ (show @off)
| Cast lhs.prettyTXT = ("((" ++ (if @word then "Word" else "WPtr") ++ ")(") >|< @val.prettyTXT >|< "))"
| Call lhs.prettyTXT = ( maybe (callCfunction @name)
fromSillyPrim
@@ -226,37 +232,37 @@ SEM Variable
| * - LP RP lhs.isLpRp = False
SEM Variable
+ | SP
+ SPTemp lhs.isPointer = True
+ | * - SP SPTemp lhs.isPointer = False
+
+SEM Variable
| Global
Local
Param lhs.prettyC = case @name of
HNmNr n OrigNone -> text ("x" ++ show n)
_ -> text (hsnShowAlphanumeric @name)
- lhs.prettyPtr = "((WPtr)" >|< text (hsnShowAlphanumeric @name) >|< ")"
| LP lhs.prettyC = text "Loc"
- lhs.prettyPtr = text "Loc"
| SP lhs.prettyC = text "SP"
- lhs.prettyPtr = text "SP"
+ | SPTemp lhs.prettyC = text "SPTemp"
| RP lhs.prettyC = text "Ret"
- lhs.prettyPtr = text "Ret"
- | Subs lhs.prettyC = if @array.isLpRp
- then @array.prettyPtr >|< show @index
- else @array.prettyPtr >|< "[" >|< show @index >|< "]"
- lhs.prettyPtr = if @array.isLpRp
- then "((WPtr)(" >|< @array.prettyPtr >|< show @index >|< "))"
- else "((WPtr)(" >|< @array.prettyPtr >|< "[" >|< show @index >|< "]" >|< "))"
+ | Subs lhs.prettyC = case (@array.isLpRp,@array.isPointer) of
+ (True ,_ ) -> @array.prettyC >|< show @index
+ (False,True ) -> @array.prettyC >|< "[" >|< show @index >|< "]"
+ (False,False) -> "((WPtr)( " >|< @array.prettyC >|< "))[" >|< show @index >|< "]"
| Aux lhs.prettyC = text "auxVar"
- lhs.prettyPtr = text "((WPtr)auxVar)"
| Ptr lhs.prettyC = text "auxPtr"
- lhs.prettyPtr = text "((WPtr)auxPtr)"
| None lhs.prettyC = error "attempt to use Variable_None as value"
- lhs.prettyPtr = error "attempt to use Variable_None as pointer"
| Unembedded lhs.prettyC = text ("UNEMB " ++ hsnShowAlphanumeric @name) -- error "attempt to use Variable_Unembedded as value"
- lhs.prettyPtr = error "attempt to use Variable_Unembedded as pointer"
SEM Variable
| SP lhs.isSP = True
| *-SP lhs.isSP = False
+
+-- SEM OffsetDesc
+-- | Number lhs.prettyC = text $ show @n
+-- | Const lhs.prettyC = error "Offset constant still present in silly2c"
%%]
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%