Fix SourceInterp's dependence on case ordering. CC #28

iu-parfunc · Jan 3, 2017 · 84ad748 · 84ad748
1 parent 3f95779
commit 84ad748
Show file tree

Hide file tree

Showing 3 changed files with 14 additions and 14 deletions.
diff --git a/gibbon-compiler/examples/Makefile b/gibbon-compiler/examples/Makefile
@@ -103,7 +103,7 @@ FAILING_TESTS ?= \
   test13_build.sexp test13b_build.sexp \
   test20_bintree.sexp test20b_bintree.sexp test20c_bintree.sexp  test20d_bintree.sexp test20e_bintree.sexp test20f_bintree.sexp \
   test11_fundata.sexp test11c_funrec.sexp test11e_funrec.sexp test12c_traverse.sexp \
-  test25c_racketcore.sexp test25d_racketcore.sexp \
+  test25d_racketcore.sexp \
   test16_forlist.sexp test17_forfold.sexp 
 # Last Line - added because they are failing under valgrind [2016.11.11]
 
@@ -148,7 +148,7 @@ build_tests: $(EXE_FILES)
 
 
 PACKED_FAILING ?=  test12_skip.sexp  test16_forlist.sexp test17_forfold.sexp \
-test20b_bintree.sexp test20f_bintree.sexp test24_defs.sexp test25c_racketcore.sexp test25d_racketcore.sexp
+test20b_bintree.sexp test20f_bintree.sexp test24_defs.sexp test25d_racketcore.sexp
 
 # test20f - wip
 # test20b_bintree.sexp   -- requires copy insertion

diff --git a/gibbon-compiler/src/Packed/FirstOrder/Common.hs b/gibbon-compiler/src/Packed/FirstOrder/Common.hs
@@ -65,6 +65,7 @@ import Debug.Trace
 -- type CursorVar = Var
 type Var    = String
 type Constr = String
+type TyCon   = String
 
 -- | Abstract location variables.
 type LocVar = Var
@@ -124,17 +125,17 @@ lookupDDef mp v =
 
 -- | Get the canonical ordering for data constructors, currently based
 -- on ordering in the original source code.  Takes a TyCon as argument.
-getConOrdering :: Out a => DDefs a -> Var -> [Constr]
+getConOrdering :: Out a => DDefs a -> TyCon -> [Constr]
 getConOrdering dd tycon = L.map fst dataCons
   where DDef{dataCons} = lookupDDef dd tycon
 
 -- | Lookup the name of the TyCon that goes with a given DataCon.
 --   Must be unique!
-getTyOfDataCon :: Out a => DDefs a -> Var -> Var
+getTyOfDataCon :: Out a => DDefs a -> Constr -> TyCon
 getTyOfDataCon dds con = fst $ lkp dds con
 
 -- | Look up the numeric tag for a dataCon 
-getTagOfDataCon :: Out a => DDefs a -> Var -> Word8
+getTagOfDataCon :: Out a => DDefs a -> Constr -> Word8
 getTagOfDataCon dds dcon =
     -- dbgTrace 5 ("getTagOfDataCon -- "++sdoc(dds,dcon)) $
     fromIntegral ix
@@ -366,5 +367,5 @@ falsePrinted = "#f"
 
 
 -- | Map a DataCon onto the name of the generated unpack function.
-mkUnpackerName :: Constr -> Var
+mkUnpackerName :: TyCon -> Var
 mkUnpackerName tyCons = "unpack_" ++ tyCons
diff --git a/gibbon-compiler/src/Packed/FirstOrder/SourceInterp.hs b/gibbon-compiler/src/Packed/FirstOrder/SourceInterp.hs
@@ -257,7 +257,9 @@ interpProg rc Prog {ddefs,fundefs, mainExp=Just e} =
                            let FunDef{funArg=(vr,_),funBody}  = fundefs # f
                            go (M.insert vr rand env) funBody
 
-            (CaseE x1 ls1) -> do
+            (CaseE x1 []) -> error$ "SourceInterp: CaseE with empty alternatives list: "++ndoc x0
+
+            (CaseE x1 alts@((sometag,_,_):_)) -> do
                    v <- go env x1
                    case v of
                      VCursor idx off | rcCursors rc ->
@@ -266,19 +268,16 @@ interpProg rc Prog {ddefs,fundefs, mainExp=Just e} =
                            case S.viewl (S.drop off seq1) of
                              S.EmptyL -> error "SourceInterp: case scrutinize on empty/out-of-bounds cursor."
                              SerTag tg :< _rst -> do
-                               -- ASSUMPTION: Id is just an ordered index.  We could explicitly map back
-                               -- to the datacon instead...
-
-                               let (tagsym,[curname],rhs) = ls1 !! fromIntegral tg
+                               let tycon = getTyOfDataCon ddefs sometag
+                                   datacon = (getConOrdering ddefs tycon) !! fromIntegral tg
+                               let (_tagsym,[curname],rhs) = lookup3 datacon alts
                                    -- At this ^ point, we assume that a pattern match against a cursor binds ONE value.
-                                   _fields = lookupDataCon ddefs tagsym
-
                                let env' = M.insert curname (VCursor idx (off+1)) env
                                go env' rhs
                              oth :< _ -> error $ "SourceInterp: expected to read tag from scrutinee cursor, found: "++show oth
 
                      VPacked k ls2 ->
-                         let (_,vs,rhs) = lookup3 k ls1
+                         let (_,vs,rhs) = lookup3 k alts
                              env' = M.union (M.fromList (zip vs ls2)) env
                          in go env' rhs
                      _ -> error$ "SourceInterp: type error, expected data constructor, got: "++ndoc v++