Permalink
Browse files

First approach to implement closures

	($ foreign "display" display ((:string) :unit) $)

	(define (fa) "A")
	(define (fb) "B")

	(define (func1) (let ((s (fa)) (s1 (fb)))
	  (lambda (x) (let ((z "qqq"))
		 (begin (display s)
				(display (fa))
				(display (fb))
				(display s1)
				(display z)
				(display x)
				)))))

	((func1) "C")

	(display "\n")

	((func1) "E")

	(display "\nEND\n")

	:~/hop$ ./hof2.out
	ALLOC TASK CHUNK: 0x006030C0 0x00603260
	AABBqqqC
	AABBqqqE
	END
  • Loading branch information...
1 parent fbc6231 commit 0e9a44fa394761814a1e7e23dcd90b7c8bce434c @voidlizard committed Oct 3, 2011
View
1 BUGS
@@ -0,0 +1 @@
+FIXED: Unneeded closure creation
@@ -28,16 +28,20 @@ import Debug.Trace
write :: KId -> [Proc] -> CompileM [String]
write ep p = do
- (tl, tref) <- uniqSpillTagMap 1
+ (tl, tref) <- uniqSpillTagMap (closureTag+1)
runCWriterM (envInit tl tref) $ do
prologue
entrypoint $ forM_ p $ \p -> do
comment (name p)
+ comment $ printf "arity: %d freevars: %d" (arity p) (freevarsnum p)
forM_ (body p) (opcode p)
empty
epilogue
where
+
+ closureTag = 1
+
prologue :: CWriterM ()
prologue = do
@@ -46,6 +50,8 @@ write ep p = do
empty
+ indent $ printf "#define HOPCCLOSURETAG %d" (closureTag)
+
comment "FIXME: more general way to allocate the heap"
indent $ "#define HOPCINITIALHEAPSIZE 8192 // words"
indent $ stmt $ "hword_t heap[HOPCINITIALHEAPSIZE] = { 0 }"
@@ -66,6 +72,7 @@ write ep p = do
indent $ "const hopc_tagdata tagdata[] = {"
shift $ " {WORDS(sizeof(hopc_task)), {0}}"
+ shift $ ",{WORDS(sizeof(hopc_closure)), {0}} // HOPCCLOSURETAG "
-- insert spill's tags
tl <- asks spillTags
@@ -204,6 +211,17 @@ write ep p = do
activationRecord p | (slotnum p) > 0 = do
tag <- asks (fromJust . M.lookup (name p) . spillTagRefs)
shift $ stmt $ printf "hopc_push_activation_record(runtime, %d)" tag
+ let alloc = fromJust $ M.lookup (name p) funAllocMap
+ let spl = M.fromList $
+ map varname $
+ maybe [] S.toList $ M.lookup (V.entrypoint p) (spill alloc)
+ let av = M.lookup activationRecordVariable spl
+ case av of
+ Nothing -> nothing
+ Just (k,r) -> -- spill R0 first if it must be spilled
+ shift $ printf "hopc_spill(runtime, %d, %s); /* %s */" k (reg r) activationRecordVariable
+ empty
+ where varname (n, r, k) = (n,(k,r))
activationRecord _ = nothing
@@ -215,8 +233,9 @@ write ep p = do
opcode :: Proc -> Op -> CWriterM ()
opcode p (Label n) = do
- gotoLabel (show n) >> caseLabel n
- when (n == V.entrypoint p) $ activationRecord p
+ gotoLabel (show n)
+ when (n == V.entrypoint p) $ activationRecord p
+ caseLabel n
opcode _ (Branch n) = branch n
@@ -234,7 +253,7 @@ write ep p = do
opcode _ (Const (LStr s) r) = do
sname <- asks (fromJust . M.lookup s . strings) -- FIXME: must mork
- shift $ stmt $ reg r ++ " = (hword_t*)" ++ sname
+ shift $ stmt $ printf "%s = W((hword_t*)%s)" (reg r) sname
opcode _ (Move r1 r2) = shift $ stmt $ reg r2 ++ " = " ++ reg r1
@@ -249,17 +268,26 @@ write ep p = do
empty
opcode _ (CallF _ n rs r) = do
--- shiftIndent $ comment $ "foreign call " ++ n
+ shiftIndent $ comment $ "foreign call " ++ n
foreign n r rs
- empty
- opcode _ (CallC _ r _ _) = do
- shiftIndent $ comment $ "closure call " ++ reg r
+ opcode _ (CallC l rc rs _) = do
+ let cl = decorateCaseLbl (show l)
+ shiftIndent $ comment $ "closure call " ++ (reg rc)
+ shiftIndent $ comment "critical section?"
+ shift $ stmt $ printf "hopc_push_activation_record2(runtime, HOPC_CLOSURE_UNPACK_AR(runtime, P(%s)))" (reg rc)
+ shift $ stmt $ printf "hopc_spill(runtime, 0, %s)" cl -- FIXME: hardcode of activationRecordVariable slot
+ shift $ stmt $ printf "R0 = HOPC_CLOSURE_UNPACK_CHECKPOINT(runtime, P(%s))" (reg rc)
+ when (not (null rs)) $
+ shift $ printf "LOCALCALLARGS%d(%s)" (length rs) (intercalate "," (map reg rs))
+ shift $ goto' entrypointLabel
empty
- opcode _ (Spill r n) = do
+ opcode _ (Spill v r n) = do
-- shiftIndent $ comment $ "spill " ++ reg r ++ " " ++ show n
- shift $ stmt $ printf "hopc_spill(runtime, %d, %s)" n (reg r)
+ if v /= activationRecordVariable
+ then shift $ printf "hopc_spill(runtime, %d, %s); /* %s */" n (reg r) v
+ else nothing -- R0 is spilled in prologue
opcode _ (Unspill n r) = do
-- shiftIndent $ comment $ "unspill " ++ reg r ++ " " ++ show n
@@ -271,6 +299,23 @@ write ep p = do
opcode _ (BranchFalse r l) = do
shift $ stmt $ printf "if(!(%s)) %s" (reg r) (goto l)
+ opcode p (MkClos n rs rt) = do
+ lself <- funEntry (name p)
+ l <- funEntry n
+ let alloc = maybe S.empty id $ M.lookup l $ spill $ fromJust $ M.lookup n funAllocMap -- FIXME: must work but ugly
+ let slots = M.fromList $ map (\(n,_,sn) -> (n,sn))$ S.toList $ alloc
+-- let fv = slots `M.intersection` (M.fromList $ (map (\a -> (a,a))) $ funFreeVars n)
+ let fv = catMaybes $ map (flip M.lookup slots) $ funFreeVars n
+ let spl = zip rs fv
+ when (length spl /= (length.funFreeVars) n) $ error "INTERNAL ERROR / COMPILER ERROR: make-closure free vars mismatched" -- FIXME
+ tag <- asks (fromJust . M.lookup n . spillTagRefs)
+ shift $ stmt $ printf "%s = W(hopc_make_activation_record(runtime, %d))" (reg rt) tag
+ forM_ spl $ \(r,i) -> do
+ shift $ stmt $ printf "hopc_spill_ar(runtime, P(%s), %d, %s)" (reg rt) i (reg r)
+ let cl = decorateCaseLbl (show l)
+ shift $ stmt $ printf "%s = W(hopc_make_closure(runtime, %s, P(%s), HOPCCLOSURETAG))" (reg rt) cl (reg rt)
+ empty
+
opcode _ x = shiftIndent $ comment $ show x
shiftIndent :: CWriterM () -> CWriterM ()
@@ -291,10 +336,24 @@ write ep p = do
sencode s = "{" ++ enc ++ "}"
where enc = intercalate "," $ map (printf "0x%02X") $ length s : map ord s ++ [0]
+ funMap :: M.Map KId Proc
+ funMap = M.fromList $ map (\(fp@(Proc{name=n})) -> (n,fp)) p
+
+ funFreeVars :: KId -> [KId]
+ funFreeVars n = fv (fromJust (M.lookup n funMap))
+ where fv (Proc{freevarsnum=fvn, args=as}) | fvn > 0 = drop (length as - fvn) as
+ | otherwise = []
+
+ funAllocMap :: M.Map KId RegAllocation
+ funAllocMap = M.fromList $ map (\(Proc{name=n, allocation=a}) -> (n,a)) p
+
funEntry :: KId -> CWriterM Label
funEntry n =
asks (M.lookup n.entrypoints) >>= return.fromJust --- FIXME: must always work. but code is dirty
+ funVars :: KId -> [KId]
+ funVars = undefined
+
entrypointsMap =
M.fromList $ map (\p@(Proc{name=fn, entrypoint=l}) -> (fn, l)) p
@@ -48,7 +48,7 @@ convert k = do
end <- newLabel
(b, g) <- tr retval (mkFirst (Label entry)) emptyClosedGraph b
let b' = g |*><*| b <*> mkLast (I.Return retval)
- return $ Proc { name = n, args = a++f, entry = entry, body = b'}
+ return $ Proc { name = n, args = a++f, freevarsnum=length f, entry = entry, body = b'}
proc e x = error $ "NOT A FUNCTION: " ++ (show x) -- FIXME
@@ -33,7 +33,7 @@ instance NonLocal Insn where
-- successors (Assign _ _) = []
-data Proc = Proc { name :: KId, args :: [KId], entry :: Label, body :: Graph Insn C C }
+data Proc = Proc { name :: KId, args :: [KId], freevarsnum :: Int, entry :: Label, body :: Graph Insn C C }
instance Show (Insn e x) where
show (Label lbl) = show lbl ++ ":"
@@ -221,6 +221,7 @@ allocateLinearScan dict live asap p@(I.Proc {I.entry = e, I.body = g, I.name = n
useOf (I.Call _ (I.Closure n1 _) _ n) (l, v) = (l, factIns' n l v `M.union` factIns' n1 l v) -- FIXME: also count the args
useOf (I.Call _ _ _ n) (l, v) = (l, factIns' n l v) -- FIXME: also count the args ?
useOf (I.Label n) (_, v) = (n, v)
+ useOf (I.MkClos _ _ n) (l,v) = (l, factIns' n l v)
useOf _ x = x
factIns' :: KId -> Label -> M.Map KId Label -> M.Map KId Label
@@ -5,6 +5,7 @@ module Compilers.Hopc.Backend.TinyC.VM (
module Compilers.Hopc.Backend.TinyC.VM.Types
, fromIR
, spillASAP
+-- , spillFreeVars
) where
import Data.List
@@ -31,7 +32,7 @@ import qualified Compilers.Hopc.Backend.TinyC.IR as I
fromIR :: TDict -> FactBase Live -> RegAllocation -> I.Proc -> M Proc
-fromIR dict live ra p@(I.Proc {I.entry = e, I.body = g, I.name = n, I.args = as}) = do
+fromIR dict live ra p@(I.Proc {I.entry = e, I.body = g, I.name = n, I.args = as, I.freevarsnum=fvn}) = do
let (GMany _ bbb _) = g
let blocks = postorder_dfs_from bbb e
@@ -43,8 +44,15 @@ fromIR dict live ra p@(I.Proc {I.entry = e, I.body = g, I.name = n, I.args = as}
liftM (wipeSnots . mergeBlocks e) $
mapM (\b -> foldBlockNodesF (liftVM trNode) b emptyM) blocks
- return $ Proc {name = n, arity = length as, slotnum = (rsSlotMax st), body = vm, entrypoint = e}
-
+ return $ Proc { name = n
+ , arity = length as
+ , args = as
+ , slotnum = (rsSlotMax st)
+ , body = vm
+ , entrypoint = e
+ , freevarsnum = (I.freevarsnum p)
+ , allocation = ra
+ }
where
trNode :: forall e x. Insn e x -> TrM TOp
@@ -95,7 +103,11 @@ fromIR dict live ra p@(I.Proc {I.entry = e, I.body = g, I.name = n, I.args = as}
unsp <- unspill activationRecordVariable (Just closureReg)
chunkM $ unsp ++ [Return]
- trNode (I.MkClos _ _ _) = error "CLOSURES ARE NOT SUPPORTED YET" -- FIXME
+ trNode (I.MkClos fn args var) = do
+ uns <- mapM (\x -> unspill x Nothing) args >>= return . concat
+ rs <- mapM reg args
+ rt <- reg var
+ chunkM $ uns ++ [MkClos fn rs rt]
trNode _ = chunkM [Nop]
@@ -129,27 +141,43 @@ fromIR dict live ra p@(I.Proc {I.entry = e, I.body = g, I.name = n, I.args = as}
nl <- gets rsTLabel
chunkM $ areload ++ [Branch nl]
- callOf call@(I.Call l (I.Direct n False) args r) (TFun TFunLocal _ rt) = do
+-- callOf call@(I.Call l (I.Direct n False) args r) (TFun TFunLocal _ rt) = do
+ callOf call@(I.Call l ct args r) (TFun TFunLocal _ rt) = do
(spl, s) <- spillAlive l r
--- trace "SPILL ALIVE" $ trace (show spl) $ return ()
- uns <- mapM (\x -> unspill x Nothing) args >>= return . concat
+-- trace "SPILL ALIVE" $ trace (show spl) $ return ()
+ uns <- mapM (\x -> unspill x Nothing) (callv ct args) >>= return . concat
rs <- mapM reg args
lbl <- newLabel
- call <- callRet rt r (chunkMs . CallL lbl n rs) >>= \x -> chunkM $ spl ++ uns ++ x
+ callfun <- callF ct lbl rs
+ call <- callRet rt r (chunkMs . callfun) >>= \x -> chunkM $ spl ++ uns ++ x
unsp <- mapM (\(n,r) -> unspill n (Just r)) s >>= return . concat
mapM_ delSpill (map fst s)
retR <- reg r
-- trace "CALL OF" $ trace (show n) $ trace (show rt) $ return ()
chunkM $ call ++ [Label lbl] ++ movRet rt retR ++ unsp ++ [Branch l]
--- chunkM $ call ++ chunk -- ++ movRet rt retR ++ unsp
+ where callF (I.Direct n _) lbl rs = return $ CallL lbl n rs
+ callF (I.Closure n _) lbl rs = do
+ r <- reg n
+ return $ CallC lbl r rs
+
+ callv (I.Direct n _) as = as
+ callv (I.Closure n _) as = n:as
callOf (I.Call l (I.Direct n _) args r) (TFun (TFunForeign nm) _ rt) = do
uns <- mapM (\x -> unspill x Nothing) args >>= return . concat
rs <- mapM reg args
callRet rt r (chunkMs . CallF l nm rs) >>= \x -> chunkM $ uns ++ x
- callOf _ _ = error "Unsupported call type" -- FIXME ASAP
-
+ callOf (I.Call l (I.Closure n _) args r) (TFun TFunLocal atypes rt) = do
+ chunkM [Nop]
+-- error "Local closure call" -- FIXME ASAP
+
+ callOf (I.Call l (I.Closure n _) args r) (TFun (TFunForeign _) _ rt) = do
+ error "Foreign closure call" -- FIXME ASAP
+
+ callOf _ _ = do
+ error "Unsupported call type"
+
movRet :: HType -> R -> [Op]
movRet TUnit r = []
movRet _ r = [Move R1 r]
@@ -168,18 +196,21 @@ fromIR dict live ra p@(I.Proc {I.entry = e, I.body = g, I.name = n, I.args = as}
case M.lookup n sp of
Nothing -> emptyM
Just spills -> mapM spillOf (S.toList spills) >>= return.concat
+-- where nonFree s (Spill ) = not $ S.member n s
spillOf :: (KId, R, Int) -> TrM TOp
spillOf (n,r,s) = do
-- trace ("SPILL VAR " ++ show (n,r)) $ return ()
i <- gets rsSlot
spilled <- gets (M.member n . rsSpill)
- if spilled
+
+ if spilled
then emptyM
- else do let sp = Spill r i
+ else do let sp = Spill n r i
succSlot
modify(\s -> s{rsFree=r:rsFree s, rsSpill = M.insert n i (rsSpill s)})
- chunkMs sp
+ -- free vars must be spilled before closure call (outside the closure)
+ if (not (S.member n fvs)) then chunkMs sp else emptyM
spillReg :: TrM TOp
spillReg = do
@@ -230,6 +261,8 @@ fromIR dict live ra p@(I.Proc {I.entry = e, I.body = g, I.name = n, I.args = as}
unspill' Nothing _ = emptyM
+ fvs = S.fromList $ freevars fvn as
+
succSlot :: TrM ()
succSlot = do
slot <- gets rsSlot >>= return . succ
@@ -246,11 +279,14 @@ fromIR dict live ra p@(I.Proc {I.entry = e, I.body = g, I.name = n, I.args = as}
free' <- gets rsFree
ma' <- gets rsAlloc
let ma = maybe M.empty id ra
+ let rsAlloc' = ma' `M.union` ma
-- trace ("LABEL " ++ show l) $ trace ("FREE REGS ") $ trace (show rf) $ trace "<<<" $
modify (\st -> st { rsMerge = mergeOp
, rsLabel = l
- , rsAlloc = ma' `M.union` ma
- , rsFree = (maybe free' id rf)})
+ , rsAlloc = rsAlloc'
+ , rsFree = (maybe free' id rf)
+ , rsAllocTrack = M.insert l rsAlloc' (rsAllocTrack st)
+ })
reg :: KId -> TrM R
reg n = do
@@ -280,7 +316,7 @@ fromIR dict live ra p@(I.Proc {I.entry = e, I.body = g, I.name = n, I.args = as}
initR = REnv ra dict live
initS :: Label -> REnvSt
- initS l = REnvSt e M.empty M.empty [] 0 0 mergeOp l
+ initS l = REnvSt e M.empty M.empty [] 0 0 mergeOp l M.empty
mergeOp :: TOp -> TOp -> TOp
mergeOp x y = x ++ y
@@ -382,8 +418,16 @@ fromIR dict live ra p@(I.Proc {I.entry = e, I.body = g, I.name = n, I.args = as}
-- printN x = do
-- trace (printf "%-60s ;" (show x)) $ return ()
+
+--isFreeVar :: KId -> Proc -> Bool
+--isFreeVar n (Proc{args=as, freevarsnum=fvn}) = undefined
+
+freevars :: Int -> [KId] -> [KId]
+freevars n as | n > 0 = drop (length as - n) as
+ | otherwise = []
+
spillASAP :: TDict -> FactBase Live -> I.Proc -> S.Set KId
-spillASAP dict live (I.Proc{I.body=g, I.args=as}) = ofProc $ foldGraphNodes node g S.empty
+spillASAP dict live (I.Proc{I.body=g, I.args=as, I.freevarsnum=fvn}) = ofProc $ foldGraphNodes node g S.empty
where
node :: forall e x . Insn e x -> S.Set KId -> S.Set KId
node (I.Call l ct _ _ ) acc = varsOf l (varType (callvar ct) dict) `S.union` acc
@@ -394,10 +438,16 @@ spillASAP dict live (I.Proc{I.body=g, I.args=as}) = ofProc $ foldGraphNodes node
varsOf l _ = S.empty
ofProc :: S.Set KId -> S.Set KId
- ofProc asap = spills `S.intersection` asap
+-- ofProc asap = arv `S.union` fvs `S.union` (spills `S.intersection` asap)
+ ofProc asap = spills `S.intersection` ( arv `S.union` fvs `S.union` asap )
spills = S.fromList $ activationRecordVariable:as
+ fvs = S.fromList $ freevars fvn as
+
+ arv | fvn > 0 = S.singleton activationRecordVariable
+ | otherwise = S.empty
+
varType :: KId -> TDict -> HType
varType n rdict =
let tp = M.lookup n rdict
@@ -422,6 +472,7 @@ data REnvSt = REnvSt { rsLabel :: Label
, rsSlotMax :: Int
, rsMerge :: TOp -> TOp -> TOp
, rsTLabel :: Label
+ , rsAllocTrack :: M.Map Label (M.Map KId R)
}
type TrM = StateT REnvSt (ReaderT REnv M)
Oops, something went wrong.

0 comments on commit 0e9a44f

Please sign in to comment.