+seq +test/Arithmetic.hs +add/sub +compare +error reporting in uniqui…

…fyE +evalConst

Ignore-this: 541db51019a65ce9ce4f01e7225d20ac

darcs-hash:20100222140155-09b00-948fa7edc5695fa7a5671db249bfa3584d233844

Core.hs

@@ -36,10 +36,18 @@ type LocHint=String
 
 
 data Core=Core [CrData] [CrProc]
-data CrData=CrData CrName [CrName] [(CrName,[CrType])] deriving(Show)
+data CrData=CrData CrName [CrName] [(CrName,[(Bool,CrType)])] deriving(Show)
 data CrProc=CrProc CrName [CrName] CrExpr deriving(Show)
 
 
+library=M.fromList
+    [("undefined",[UError "undefined"])
+    ,("addByteRaw",f AAdd)
+    ,("subByteRaw",f ASub)
+    ,("cmpByteRaw",f CCmp)
+    ,("seq",[PushArg 1,Push 0,Reduce RAny,Update 1,Pop 1,PushArg 2,Slide 3])
+    ]
+    where f op=[PushArg 2,PushArg 2,Arith op,Slide 3]
 
 
 
@@ -56,7 +64,7 @@ uniquifyP m r (CrProc n as e)=CrProc n (map (m' M.!) as) $ uniquifyE m' r e
     where m'=bind r m as
 
 uniquifyE :: M.Map CrName CrName -> String -> CrExpr -> CrExpr
-uniquifyE m r (CrVar v)=CrVar $ m M.! v
+uniquifyE m r (CrVar v)=CrVar $ M.findWithDefault (error $ "uniquifyE:"++v) v m
 uniquifyE m r (CrApp e0 e1)=CrApp (uniquifyE m n1 e0) (uniquifyE m n2 e1)
     where [n1,n2]=branch 2 r
 uniquifyE m r (CrCstr t es)=CrCstr t $ zipWith (uniquifyE m) ns es
@@ -171,24 +179,24 @@ replaceVar t e=e
 
 
 compile :: Core -> Process (M.Map String [GMCode])
-compile (Core ds ps)=return $ M.fromList $ undef:map (compileP m) (ps++pds)
+compile (Core ds ps)=return $ M.union library $ M.fromList (map (compileP m) (ps++pds))
     where
         m=M.fromList cons
         (pds,cons)=unzip $ concatMap convertData ds
-        undef=("undefined",[UError "undefined"])
 
 
 -- | Convert one data declaration to procs and cons.
 convertData :: CrData -> [(CrProc,(String,Int))]
 convertData (CrData _ _ cs)=zipWith convertDataCon [0..] cs
 
--- tag, not arity
-convertDataCon :: Int -> (CrName,[CrType]) -> (CrProc,(String,Int))
-convertDataCon t (name,xs)=
-    (CrProc name args $ CrCstr t $ map CrVar args,(name,t))
+-- | Int argument is a tag, not an arity
+convertDataCon :: Int -> (CrName,[(Bool,CrType)]) -> (CrProc,(String,Int))
+convertDataCon t (name,xs)=(CrProc name (map snd args) exp,(name,t))
     where
-        args=take n $ stringSeq "#d"
-        n=length xs
+        exp=foldr (\v e->multiApp (CrVar "seq") [v,e]) con $ map (CrVar . snd) sarg
+        con=CrCstr t $ map (CrVar . snd) args
+        sarg=filter (fst . fst) args
+        args=zip xs $ stringSeq "#d"
 
 
 
@@ -219,7 +227,7 @@ smplE t (CrCase ec cs)
 
         nrmcons=map (\(x,y,z)->(x,y,smplE t z)) nrmcs
         cocons x=map (\(c,n)->(c,replicate n "",smplE t x)) $ F.toList s
-        s=S.difference (t M.! (fst $ head cons)) (S.fromList cons)
+        s=S.difference (M.findWithDefault (error "smplE") (fst $ head cons) t) (S.fromList cons)
         cons=filter (not . null . fst) $ map (\(x,y,_)->(x,length y)) cs
 smplE t x=x
 

Front.hs

@@ -130,8 +130,10 @@ convDataDecl :: HsDecl -> CrData
 convDataDecl (HsDataDecl loc ctx (HsIdent name) vars cons derv)=
     CrData name [] $ map convDataCon cons
 
-convDataCon :: HsConDecl -> (CrName,[CrType])
-convDataCon (HsConDecl loc (HsIdent name) ts)=(name,replicate (length ts) undefined)
+convDataCon :: HsConDecl -> (CrName,[(Bool,CrType)])
+convDataCon (HsConDecl loc (HsIdent name) ts)=(name,map f ts)
+    where f (HsBangedTy ty)=(True,convType ty)
+          f (HsUnBangedTy ty)=(False,convType ty)
 
 convFunDecl :: HsDecl -> CrProc
 convFunDecl (HsFunBind [HsMatch loc (HsIdent n) args (HsUnGuardedRhs e) []])
@@ -150,7 +152,8 @@ convExp (HsLambda loc as e)=CrLm (map f as) (convExp e)
 convExp (HsVar (UnQual (HsIdent x)))=CrVar x
 convExp (HsApp e0 e1)=CrApp (convExp e0) (convExp e1)
 convExp e@(HsCase _ _)=convFullCase e
-convExp (HsLit (HsInt n))=error "convExp: int"-- CrA (h,Nothing) $ CrInt $ fromIntegral n
+-- convExp (HsLit (HsInt n))=error "convExp: int"-- CrA (h,Nothing) $ CrInt $ fromIntegral n
+convExp (HsLit (HsInt n))=CrByte $ fromIntegral n
 convExp (HsLit (HsChar ch))=CrByte $ fromIntegral $ ord ch
 convExp (HsLet bs e)=CrLet True (map (toVP . convFunDecl) bs) (convExp e)
     where
@@ -160,6 +163,11 @@ convExp (HsLet bs e)=CrLet True (map (toVP . convFunDecl) bs) (convExp e)
 convExp e=error $ "ERROR:convExp:"++show e
 
 
+convType :: HsType -> CrType
+convType (HsTyVar (HsIdent x))=CrTyVar x
+convType (HsTyCon (UnQual (HsIdent x)))=CrTyCon x
+convType (HsTyApp t0 t1)=CrTyApp (convType t0) (convType t1)
+convType t=error $ "convType: "++show t
 
 
 -- | Convert 'HsCase'(desugared) to 'CrExpr'
@@ -412,8 +420,8 @@ instance WeakDesugar HsExp where
     wds (HsLeftSection e op)=HsApp (opToExp op) (wds e)
     wds (HsRightSection op e)=HsApp (HsApp (HsVar (UnQual (HsIdent "flip"))) (opToExp op)) (wds e)
     wds (HsIf c e0 e1)=HsCase (wds c)
-        [HsAlt wdsDummySrc (HsPVar (HsIdent "True")) (HsUnGuardedAlt (wds e0)) []
-        ,HsAlt wdsDummySrc (HsPVar (HsIdent "False")) (HsUnGuardedAlt (wds e1)) []]
+        [HsAlt wdsDummySrc (HsPApp (UnQual (HsIdent "True" )) []) (HsUnGuardedAlt (wds e0)) []
+        ,HsAlt wdsDummySrc (HsPApp (UnQual (HsIdent "False")) []) (HsUnGuardedAlt (wds e1)) []]
     wds (HsCase e als)=HsCase (wds e) (map wds als)
     wds (HsLet decls e)=HsLet (map wds decls) (wds e)
     wds (HsLambda loc ps e)=HsLambda loc (map wds ps) (wds e)
@@ -482,7 +490,6 @@ unguardG :: (a -> (HsExp,HsExp)) -> [a] -> HsExp
 unguardG _ []=HsVar $ UnQual $ HsIdent "undefined"
 unguardG f (x:xs)=let (cond,exp)=f x in HsIf cond exp $ unguardG f xs
 
-
 wdsDummySrc=SrcLoc "<WeakDesugar>" 0 0
 
 

GMachine.hs

@@ -165,6 +165,8 @@ fPos (UnPack _)=StackA
 fPos (Update _)=StackT
 fPos (Pop _)=StackT
 fPos (GMachine.Alloc _)=fPos $ PushByte 0
+fPos (Arith _)=StackT
+fPos (UError _)=StackA -- any position will do, actually.
 fPos x=error $ show x
 
 
@@ -397,6 +399,76 @@ compileCode m (UError s:_)=Clear ptr:concatMap (\d->[Val ptr d,Output ptr]) ds
         ds=head ns:zipWith (-) (tail ns) ns
         ns=map ord s
         ptr=Memory "S0" 0
+compileCode m (Arith op:is)=contWith m StackT is $
+    [SAM.Alloc "x"
+    ,SAM.Alloc "y"
+    ,Move (Memory "S0" 0) [Register "x"]
+    ,Move (Memory "S0" (-1)) [Register "y"]
+    ,Locate (-2)
+    ,Inline "#stack1S0" []
+    ,Inline "#heapRefHp" ["x"]
+    ,Copy (Memory "Hp" 3) [Register "x"]
+    ,Inline "#heap1Hp" []
+    ,Inline "#heapRefHp" ["y"]
+    ,Delete "y"
+    ,SAM.Alloc "temp"
+    ,Copy (Memory "Hp" 3) [Register "temp"]
+    ]++
+    f (Register "temp") (Register "x") op++
+    [Delete "temp"
+    ,SAM.Alloc "addr"
+    ,Inline "#heapNewHp" ["addr"]
+    ,Clear (Memory "Hp" 0) ,Val (Memory "Hp" 0) 6
+    ,Clear (Memory "Hp" 1) ,Val (Memory "Hp" 1) 0
+    ,Clear (Memory "Hp" 2) ,Val (Memory "Hp" 2) $ tag op
+    ,Clear (Memory "Hp" 3) ,Move (Register "x") [Memory "Hp" 3] ,Delete "x"
+    ,Clear (Memory "Hp" 4) ,Copy (Register "addr") [Memory "Hp" 4]
+    ,Clear (Memory "Hp" 5) ,Val (Memory "Hp" 5) 6
+    ,Clear (Memory "Hp" 6)
+    ,Inline "#heap1Hp" []
+    ,Inline "#stackNewS0" []
+    ,Move (Register "addr") [Memory "S0" 0]
+    ,Delete "addr"
+    ]
+    where
+        tag CCmp=structTag
+        tag _=constTag
+        f from to AAdd=[While from [Val from (-1),Val to 1]]
+        f from to ASub=[While from [Val from (-1),Val to (-1)]]
+        f from to CCmp=
+            [SAM.Alloc "t"
+            ,Val (Register "t") 1
+            ,While (Register "t")
+                [SAM.Alloc "s"
+                ,Copy from [Register "s"]
+                ,Val (Register "t") 1
+                ,While (Register "s")
+                    [Clear (Register "s")
+                    ,Val (Register "t") (-1)
+                    ]
+                ,Copy to [Register "s"]
+                ,While (Register "s")
+                    [Clear (Register "s")
+                    ,Val (Register "t") (-1)
+                    ]
+                ,Val (Register "s") 1
+                ,While (Register "t")
+                    [Clear (Register "t")
+                    ,Val (Register "s") (-1)
+                    ]
+                ,Move (Register "s") [Register "t"]
+                ,Delete "s"
+                ,Val from (-1)
+                ,Val to (-1)
+                ]
+            ,Val from 1
+            ,Val to 1
+            ,While from [Clear from,Val (Register "t") 1]
+            ,While to [Clear to,Val (Register "t") 2]
+            ,Move (Register "t") [to] -- 0:EQ 1:from>to 2:to<from
+            ,Delete "t"
+            ]
+
 
 
 
@@ -412,20 +484,31 @@ data GMCode
     =Slide Int -- ^ pop 1st...nth items
     |Update Int -- ^ replace all reference to the nth address to 0th address.
     |Pop Int -- ^ remove n items
-    |MkApp -- ^ function must be pushed after arguments. then use this.
     |Push Int
-    |PushArg Int
     |PushSC String
-    |PushByte Int
+    |Alloc Int
+    |Swap -- ^ used for implementing 'elimReduce'
+    |Reduce RHint -- ^ reduce stack top to WHNF
+    -- function
+    |MkApp -- ^ function must be pushed after arguments. then use this.
+    |PushArg Int
+    -- data structure
     |Pack Int Int
     |Case [(Int,[GMCode])]
     |UnPack Int
-    |Alloc Int
-    |Reduce RHint -- ^ reduce stack top to WHNF
-    |Swap -- ^ used for implementing 'elimReduce'
+    -- arithmetic
+    |PushByte Int
+    |Arith ArithOp
+    -- error
     |UError String -- ^ output the given string with undefined consequence
     deriving(Show)
 
+data ArithOp
+    =AAdd
+    |ASub
+    |CCmp
+    deriving(Show)
+
 data RHint
     =RByte
     |RE
@@ -554,6 +637,14 @@ evalGM fl fs (Update n:xs)=do
         fH f t (Struct tag xs)=Struct tag $ map (fS f t) xs
         fH _ _ x=x
 evalGM fl fs (GMachine.Alloc n:xs)=evalGM fl fs $ replicate n (PushByte 0)++xs
+evalGM fl fs (Arith op:xs)=do
+    Const x<-pop >>= refHeap
+    Const y<-pop >>= refHeap
+    case op of
+        AAdd -> alloc (Const $ (x+y) `mod` 256) >>= push
+        ASub -> alloc (Const $ (x-y) `mod` 256) >>= push
+        CCmp -> alloc (Struct (if x==y then 0 else if x<y then 1 else 2) []) >>= push
+    evalGM fl fs xs
 evalGM _ _ x=error $ "evalGM: unsupported: "++show x
 
 
@@ -580,11 +671,8 @@ collect heap addr=S.insert addr $
         _ -> S.empty
 
 
-refHeap0 :: Monad m => Address -> GMST m GMNode
-refHeap0 addr=liftM ((M.!addr) . heap) get
-
 refHeap :: Monad m => Address -> GMST m GMNode
-refHeap addr=refHeap0 addr
+refHeap addr=liftM ((M.!addr) . heap) get
 
 refStack :: Monad m => Int -> GMST m Address
 refStack n=liftM ((!!n) . stack) get

SRuntime.hs

@@ -16,7 +16,7 @@ genLibrary ns=concat
     ,genHeapLib "Hp" -- primiary heap
     ,genHeapLib "Hs" -- secondary heap for GC
     ,genGCLib ns
-    ,[rootProc,setupMemory,mainLoop,eval,evalApp,evalSC,evalStr,evalE]
+    ,[rootProc,setupMemory,mainLoop,eval,evalApp,evalSC,evalConst,evalStr,evalE]
     ,[isEqual,rewrite "S0",rewrite "Hp"]
     ]
 
@@ -74,7 +74,7 @@ eval=SProc "%eval" ["sc"]
     ,Dispatch "tag"
         [(appTag,[Inline "%evalApp" []])
         ,(scTag,[Inline "%evalSC" ["sc"]])
-        ,(constTag,[])
+        ,(constTag,[Inline "%evalConst" ["sc"]])
         ,(structTag,[Inline "%evalStr" ["sc"]])
         ]
     ,Delete "tag"
@@ -96,6 +96,22 @@ evalSC=SProc "%evalSC" ["sc"]
     ,Inline "#heap1Hp" []
     ]
 
+evalConst=SProc "%evalConst" ["sc"]
+    [Inline "#heap1Hp" []
+    ,Inline "#stackTopS0" []
+    ,While (Memory "S0" (-1)) -- non-root frame -> get sc
+        [Val (Register "sc") (-1) -- sc:=0
+        ,Alloc "addr"
+        ,Move (Memory "S0" (-1)) [Register "addr"]
+        ,Move (Memory "S0" 0) [Memory "S0" (-1)] -- move exp to top
+        ,Locate (-1)
+        ,Inline "#stack1S0" []
+        ,Inline "#heapRefHp" ["addr"]
+        ,Delete "addr"
+        ,Copy (Memory "Hp" 3) [Register "sc"]
+        ,Inline "#heap1Hp" []
+        ]
+    ]
 
 evalStr=SProc "%evalStr" ["sc"]
     [Inline "#heap1Hp" []
@@ -474,8 +490,10 @@ gcCopy ns=SProc "#gcCopy" []
     ]
     where
         f s=(s,
-            concatMap (\x->[Alloc $ tempN x,Copy (Memory "Hs" $ 1+x) [Register $ tempN x]]) [1..s-2]++
-            [Inline "#heap1Hs" []
+            concatMap (\x->[Alloc $ tempN x,Move (Memory "Hs" $ 1+x) [Register $ tempN x]]) [1..s-3]++
+            [Alloc $ tempN $ s-2
+            ,Copy (Memory "Hs" $ s-1) [Register $ tempN $ s-2]
+            ,Inline "#heap1Hs" []
             ,Inline "#heapNew_Hp" []
             ,Move (Register $ tempN $ s-2) [Memory "Hp" 0,Memory "Hp" $ s-1]
             ,Delete $ tempN $ s-2

auto-test

@@ -14,9 +14,8 @@ and test_bf test/ExplicitCase.hs
 and test_bf test/Hello.hs
 and test_bf test/LocalFun.hs
 and test_bf test/Lambda.hs
-# and test_bf test/CharIf.hs
-# and test_bf test/Numeric.hs
-# and test_bf test/Arithmetic.hs
+and test_bf test/Arithmetic.hs
+# and test_bf test/TypeClass.hs
 # and test_bf test/ConstPattern.hs
 # and test_bf test/
 

test/Arithmetic.hs

@@ -0,0 +1,2 @@
+
+main=Output (addByte (addByte 1 1) (addByte 1 'l')) Halt

test/Hello.hs

@@ -1,6 +1,5 @@
 
-main=outputStr Halt "Hello World!"
---main=outputStr Halt "He"
+main=outputStr Halt "Hello!"
 
 outputStr k []=k
 outputStr k (x:xs)=Output x (outputStr k xs)