[code cleanups, get rid of old Grin.Primitives module
John Meacham <john@repetae.net>**20060129103438] hunk ./Grin/Primitives.hs 1
-module Grin.Primitives(primSc, builtins) where
-
-import Grin.Val
-import Grin.Grin
-import GenUtil
-import Name.VConsts
-import Atom
-import Char(chr,ord)
-import Options
-import C.Prims
-
-createPrim name as exp = sc where
-    sc = (n,Tup as :-> exp)
-    --tenv = (n,([ v | Var _ v <- as ],TyNode))
-    n = toAtom $ "b" ++ name
-
---primAp = createPrim "ap" [p1,p2] (gEval p1 :>>= (n3 :-> gApply n3 p2))
-
-primitive = Primitive { primRets = Nothing }
-
--- Eval all arguments
-createPrim' name as exp = sc where
-    sc = (n,Tup [ Var n (TyPtr TyNode) | Var n _ <- as ] :-> exp')
-    n = toAtom $ "b" ++ name
-    exp' = foldr g exp as where
-        g v@(Var x TyNode) r = gEval (Var x (TyPtr TyNode)) :>>= (v :-> r)
-
-litPrim :: Tag -> String -> Int -> Builtin -> ((Atom,Lam),(Atom,Builtin))
-litPrim tag name nargs fn = (createPrim' name as (f as $ Prim prim as'), (n,fn)) where
-    n = toAtom $ "@" ++ name
-    var n = Var n (Ty tag)
-    as =  [ Var n TyNode | n <- [ v1 .. V nargs ]]
-    as' =  [ var n | n <- [ v1 .. V nargs ]]
-    f [] e = e
-    f ((a@(Var n _)):as) e = Return a :>>= NodeC tag [var n] :-> f as e
-    f a b = error $ "litPrim: " ++ show (a,b)
-    prim = primitive { primRets = Just [ toAtom $ "CPrelude." ++ show x | x <- [LT .. ]], primName = n, primType = (TyTup (replicate nargs (Ty tag)),TyNode) , primAPrim = primPrim (show n) }
-
-intPrim :: Tag -> String -> Int -> Builtin -> ((Atom,Lam),(Atom,Builtin))
-intPrim tag name nargs fn = (createPrim' name as (f as (Prim prim as')), (n,fn)) where
-    n = toAtom $ "@" ++ name
-    var n = Var (V n) (Ty tag)
-    f [] e = e :>>= var 1 :-> Return (NodeC tag [var 1])
-    f ((a@(Var (V n) _)):as) e = Return a :>>= NodeC tag [var n] :-> f as e
-    as =  [ Var (V n) TyNode | n <- [ 1 .. nargs ]]
-    as' =  [ var n | n <- [ 1 .. nargs ]]
-    prim = primitive { primName = n, primType = (TyTup (replicate nargs (Ty tag)),Ty tag) }
-
-eqPrim :: Tag -> String -> Int -> Builtin -> ((Atom,Lam),(Atom,Builtin))
-eqPrim tag name nargs fn = (createPrim' name as (f as (Prim prim as')), (n,fn)) where
-    n = toAtom $ "@" ++ name
-    var n = Var (V n) (Ty tag)
-    f [] e = e
-    f ((a@(Var (V n) _)):as) e = Return a :>>= NodeC tag [var n] :-> f as e
-    as =  [ Var (V n) TyNode | n <- [ 1 .. nargs ]]
-    as' =  [ var n | n <- [ 1 .. nargs ]]
-    prim = primitive { primRets = Just [toAtom "CPrelude.True", toAtom "CPrelude.False"],primName = n, primType = (TyTup (replicate nargs (Ty tag)),TyNode)  , primAPrim = primPrim (show n)}
-
-intPrimN :: Tag -> String -> Int -> Int -> Builtin -> ((Atom,Lam),(Atom,Builtin))
-intPrimN tag name nargs 2 fn = (createPrim' name as (f as (Prim prim as')), (n,fn)) where
-    n = toAtom $ "@" ++ name
-    var n = Var (V n) (Ty tag)
-    f [] e =
-        e :>>= Tup rs' :->
-        Store (NodeC tag [rs' !! 0]) :>>= p1 :->
-        Store (NodeC tag [rs' !! 1]) :>>= p2 :->
-        Return (NodeC (toAtom "CPrelude.(,)") [p1,p2])
-    f ((a@(Var (V n) _)):as) e = Return a :>>= NodeC tag [var n] :-> f as e
-    as =  [ Var (V n) TyNode | n <- [ 1 .. nargs ]]
-    as' =  [ var n | n <- [ 1 .. nargs ]]
-    rs' =  [ var n | n <- [ 1 .. 2 ]]
-    prim = primitive { primName = n, primType = (TyTup (replicate nargs (Ty tag)),TyTup (replicate 2 $ Ty tag))  , primAPrim = primPrim (show n)}
-
---primQuotRem = intPrimN cInt "primQuotRem" 2 2 f where
---    f [Lit x tx,Lit y ty] | tx == ty = return $  let (a,b) = (quotRem x y) in Tup [Lit a tx, Lit b tx]
---    f xs = error $ "primQuotRem: " ++ show xs
-
-fromBoxedLit (NodeC _ [Lit n _]) = return n
-fromBoxedLit _ = fail "not boxed lit"
-
---binaryOp name op = intPrim (toAtom "int") name 2 f where
---    f [Lit x tx,Lit y ty] | tx == ty = return $  Lit (x `op` y) tx
---    f xs = error $ "binaryOp: " ++ name ++ " " ++ show xs
-
-primId name = createPrim' name [n1] (Return n1)
-
---primTimes = binaryOp "primTimes" (*)
---primPlus = binaryOp "primPlus" (+)
---primMinus = binaryOp "primMinus" (-)
-
-{-
-primPlus = sprim "primPlus" 2 f where
-    f [NodeC tx [Lit x tx'],NodeC ty [Lit y ty']]
-        | tx == ty && tx' == ty' = return $ NodeC tx [Lit (x + y) tx']
-primMinus = sprim "primMinus" 2 f where
-    f [NodeC tx [Lit x tx'],NodeC ty [Lit y ty']]
-        | tx == ty && tx' == ty' = return $ NodeC tx [Lit (x - y) tx']
--}
---primNegate = intPrim cInt "primNegate" 1 f where
---    f [Lit x tx] = return $ Lit (negate x) tx
-
-primEq x = eqPrim (toAtom $ 'C':x) ("primEq" ++ x)  2 f where
-    f [Lit x tx,Lit y ty]
-        | tx == ty  = return $ if x == y then vTrue else vFalse
-primCompare x = litPrim (toAtom $ 'C':x) ("primCompare" ++ x) 2 f where
-    f [Lit x tx',Lit y ty']
-        |  tx' == ty' = return $ vOrdering (compare x y)
-    f xs = error $ "primCompare: " ++ show xs
-
-
-sprims = [
---    primPlus,
- --   primMinus,
---    primNegate,
---    primEq "Int",
---    primEq "Char",
---    primCompare "Int",
---    primCompare "Char",
---    primTimes,
-    (primPutChar,primPutCharBuiltin),
-    (primGetChar,primGetCharBuiltin),
-    (primGetArgs,primGetArgsBuiltin)
---    primQuotRem
-    ]
-
-builtins = snds sprims
-primSc = fsts sprims ++ [
---    primId "unsafeCoerce",
---    primId "primFromInteger",
---    primId "primToInteger",
---    (toAtom "bord", primLitCast (cChar,tCharzh) (cInt,tIntzh)),
---    (toAtom "bchr", primLitCast (cInt,tIntzh) (cChar,tCharzh)),
---    createPrim "error" [p1] (Error "error call" TyNode),
-    --primAp,
---    primExit
-    ]
-
-primLitCast (c1,t1) (c2,t2) = (Tup [p1] :->
-    gEval p1 :>>= NodeC c1 [Var v2 t1] :->
-    Cast (Var v2 t1) t2 :>>= Var v3 t2 :->
-    Return (NodeC c2 [Var v3 t2])
-    )
-
-primitivePutChar = primitive {
-    primName = toAtom "@putChar",
-    primAPrim = primPrim  "@putChar",
-    primType = (TyTup [tCharzh],tyUnit)
-    }
-primitiveGetChar = primitive {
-    primName = toAtom "@getChar",
-    primAPrim = primPrim  "@getChar",
-    primType = (TyTup [],tCharzh)
-    }
-
-primPutCharBuiltin = (primName primitivePutChar, \[Lit n _] -> putChar (chr n) >> return unit)
-primGetCharBuiltin = (primName primitiveGetChar, \[] -> getChar >>= \c -> return (Lit (ord c) tCharzh))
-
-primGetChar = (toAtom "bprimGetChar",
-    Tup [p0] :->
-    Prim primitiveGetChar [] :>>= c1 :->
-    Store (NodeC cChar [c1]) :>>= p2 :->
-    Return (NodeC (toAtom "CJhc.IO.JustIO") [p0, p2])
-    )
-
-primPutChar = (toAtom "bprimPutChar",
-    Tup [p1,p0] :->
-    gEval p1 :>>= NodeC cChar [c1] :->
-    Prim primitivePutChar [c1] :>>= unit :->
-    Return (NodeC (toAtom "CJhc.IO.JustIO") [p0, Const $ vUnit])
-    )
-
---  unboxed varients are only different for certain types.
-
--- binOp :: (ToVal a, ToVal b, FromVal c) =>  ( a -> b -> c) -> ((Atom,Lam),(Atom,Builtin))
--- binOp fn =
-
-
-
-
-primGetArgsBuiltin = (primName primitiveGetArgs, \[] -> return $ Const $ toVal (map toVal (optProgArgs options)))
-primitiveGetArgs = primitive {
-    primName = toAtom "@getArgs",
-    primType = (TyTup [],TyPtr TyNode)
-    }
-primGetArgs = (toAtom "bprimGetArgs",
-    Tup [p0] :->
-    Prim primitiveGetArgs [] :>>= p1 :->
-    Return (NodeC (toAtom "CJhc.IO.JustIO") [p0,p1])
-    )
-
---primExitBuiltin = (primName primitiveExit, \[] -> return $ Const $ toVal (map toVal (optProgArgs options)))
---primitiveExit = Primitive {
---    primName = toAtom "@exit",
---    primType = (TyTup [Ty cInt],tyUnit)
---    }
-primExit = (toAtom "bexit",
-    Tup [p3,p1] :->
-    gEval p3 :>>= NodeC cInt [Var v1 tIntzh] :->
-    Error "exit" TyNode
-    --Prim primitiveExit [Var 1 (Ty cInt)] :>>= unit :->
-    --Return (NodeC (toAtom "CPrelude.IO.JustIO") [Const $ toVal ()])
-    )
-
-c1 = Var v1 tCharzh
---world__ = Const (NodeC (toAtom "CJhc.IO.World__") [])
-
-{-
-primIO name action as rt = (createPrim' name as exp ,action) where
-    as' = [ Var | a <- as ++ [TyNode] | v <- [v1 ..]]
-    exp = Prim Primitive { primName = pn, primType =
-    pn = toAtom $ "@" ++ name
--}
-
rmfile ./Grin/Primitives.hs
hunk ./Grin/FromE.hs 76
-convertName n = toAtom (t':s) where
-    (t,s) = fromName n
-    t' | t == TypeConstructor = 'T'
-       | t == DataConstructor = 'C'
-       | t == Val = 'f'
-       | otherwise = error $ "convertName: " ++ show (t,s)
hunk ./Grin/Grin.hs 13
-    Props(..),
hunk ./Grin/Grin.hs 37
+    valToItem,
hunk ./Grin/Grin.hs 46
+    combineItems,
hunk ./Grin/Grin.hs 256
-data Props = Props {
-    hasSideEffects :: Flag,  -- ^ has side effects
-    causesError    :: Flag,  -- ^ contains Error or aborting primitive
-    allocsMem      :: Flag   -- ^ calls store (does not count as side effect)
-    } deriving(Show)
-
-instance Monoid Props where
-    mempty = Props mempty mempty mempty
-    Props x y z `mappend` Props a b c = Props (mappend x a) (mappend y b) (mappend z c)
-instance SemiBooleanAlgebra Props where
-    Props x y z && Props a b c = Props ((&&) x a) ((&&) y b) ((&&) z c)
-    Props x y z || Props a b c = Props ((||) x a) ((||) y b) ((||) z c)
hunk ./Grin/Grin.hs 258
-propsMaybe = Props { hasSideEffects = Maybe, causesError = Maybe, allocsMem = Maybe }
-
-props :: Exp -> Props
-props (x :>>= (_ :-> y)) = props x && props y
-props (Case _ xs) = or1 [ props x | _ :-> x <- xs ]
-props Return {} = mempty
-props Store {} = mempty { allocsMem = Yes }
-props Fetch {} = mempty
-props Update {} = mempty { hasSideEffects = Yes }
-props Error {} = mempty { causesError = Yes }
-props Cast {} = mempty
-props _ = error "props"
hunk ./Grin/Grin.hs 572
+valToItem (Const v) = HeapValue (Set.singleton (HV (-1) (Right v)))
+valToItem (NodeC t as) = NodeValue (Set.singleton (NV t (map valToItem as)))
+valToItem (Lit _ ty) = BasicValue ty
+valToItem (Tup as) = TupledValue (map valToItem as)
+valToItem (Tag _) = BasicValue TyTag
+
hunk ./Grin/Show.hs 82
-    | t == Ty cChar = char 'c' <> tshow i
+    | t == Ty "uint32_t" = char 'c' <> tshow i
hunk ./Grin/Val.hs 1
-module Grin.Val(FromVal(..),ToVal(..),cChar,cInt,tn_2Tup,world__,pworld__,valToList) where
+module Grin.Val(FromVal(..),ToVal(..),tn_2Tup,world__,pworld__,valToList,convertName) where
hunk ./Grin/Val.hs 3
-import Grin.Grin
hunk ./Grin/Val.hs 5
+import Grin.Grin
hunk ./Grin/Val.hs 7
+import Name.Names
+import Name.Name
hunk ./Grin/Val.hs 11
-nil = (toAtom "CPrelude.[]")
-cons =  (toAtom "CPrelude.:")
-
-cChar = toAtom "CPrelude.Char"
-cInt = toAtom "CPrelude.Int"
-tn_2Tup = toAtom "CPrelude.(,)"
-tn_True = toAtom "CPrelude.True"
-tn_False = toAtom "CPrelude.False"
-tn_unit = toAtom "CPrelude.()"
+nil      = convertName dc_EmptyList -- (toAtom "CPrelude.[]")
+cons     = convertName dc_Cons -- (toAtom "CPrelude.:")
+cChar    = convertName dc_Char -- toAtom "CPrelude.Char"
+cInt     = convertName dc_Int --toAtom "CPrelude.Int"
+tn_2Tup  = convertName $ nameTuple DataConstructor 2
+tn_True  = convertName dc_True  -- toAtom "CPrelude.True"
+tn_False = convertName dc_False -- toAtom "CPrelude.False"
+tn_unit  = convertName dc_Unit -- toAtom "CPrelude.()"
hunk ./Grin/Val.hs 26
-world__ = NodeC (toAtom "CJhc.IO.World__") []
+world__ = NodeC (convertName $ dc_World__) []
hunk ./Grin/Val.hs 107
+convertName n = toAtom (t':s) where
+    (t,s) = fromName n
+    t' | t == TypeConstructor = 'T'
+       | t == DataConstructor = 'C'
+       | t == Val = 'f'
+       | otherwise = error $ "convertName: " ++ show (t,s)
+
+
+
hunk ./Main.hs 480
-    printTable "Argument points-to" (grinArgTags x)
+    printTable "Argument points-to" (Map.map (map dereferenceItem) $ grinArgTags x)
hunk ./Main.hs 508
+dereferenceItem (HeapValue hvs) | not $ Set.null hvs = combineItems (map f $ Set.toList hvs) where
+    f (HV _ (Right v)) = valToItem v
+    f (HV _ (Left (_,i))) = i
+dereferenceItem x = x