module GcodeFix(gcodeFixInit,gcodeFix,gcodeFixFinish) where
import Gcode
import IntState(uniqueIS,lookupIS,globalIS,arityIS,miIS)
import Memo
import AssocTree
import TokenId (TokenId(..))
import State
import Info hiding (TokenId)
import Util.Extra
import GcodeLow(cap0,caf,fun,string,profstatic,profproducer,profconstructor,profmodule,tprofmodule,tprofmodulesub,consttable,lowInteger,extra,wsize,align)
import GcodeSpec(fixProfstatic,compilerProfstatic)
import Flags
import Maybe
data Down = Down
data Thread = Thread
IntState -- state
Bool -- prof
(AssocTree (Int,Int) Int) -- profstatics
((AssocTree String Int),[(Int,Gcode)]) -- strings, extralabels
Bool -- live
(Memo Int) -- used labels
Int [Gcode] -- before
Int [Gcode] -- after
type FixState = (AssocTree (Int,Int) Int, (AssocTree String Int, [(Int,Gcode)]))
gcodeFixInit :: IntState -> Flags -> (IntState,(AssocTree a b,(AssocTree [Char] Int,[(Int,Gcode)])))
gcodeFixInit state flags =
case uniqueIS state of
(mlabel,state) ->
let fn = fromEnum (miIS state)
name = (show . profI . fromJust . lookupIS state . toEnum) fn
in if sProfile flags || sFunNames flags || sTprof flags then
if sPart flags then
(state,(initAT,(initAT,[(fromEnum mlabel,GLOBAL profmodule fn)])))
else
(state,(initAT,(addAT initAT sndOf name (fromEnum mlabel),[(fromEnum mlabel,GLOBAL profmodule fn)])))
else
(state,(initAT,(initAT,[])))
gcodeFix flags state (profstate,stringstate) gcode =
let prof = sProfile flags
tprof = sTprof flags
funnames = prof || tprof || sFunNames flags
thread = (tprof,funnames,prof,state,profstate,stringstate)
in case {- mapS -} fixOne gcode () thread of
(gcode,(prof,state,profstate,stringstate)) ->
(state,(profstate,stringstate),gcode)
gcodeFixFinish state (profstate,(strings,elabels)) =
[concatMap (fixProfstatic state) (listAT profstate)] ++ [concatMap (fixString elabels) (listAT strings)]
{---------------- DAVID ------------------- -}
escNul [] = []
escNul ('\\':xs) = '\\':'\\': escNul xs
escNul ('\0':xs) = '\\':'\0': escNul xs
escNul (x:xs) = x : escNul xs
{---------------- DAVID ------------------- -}
fixString elabels (s,i) = (map snd . filter ((i==).fst)) elabels ++ [LOCAL string i, DATA_S s]
fixOne [] _ (tprof,funnames,prof,state,profstatics,strings) =
([],(prof,state,profstatics,strings))
fixOne (g@(STARTFUN pos fn):gs) _ (tprof,funnames,prof,state,profstatics,strings) =
let a = arityIS state (toEnum fn)
thread = Thread state prof profstatics strings True initM
(if funnames then -2 else 0) [] -- if funnames | profile then Position at -2 and Name at -1
(2+if prof then extra else 0) [] -- size/arity at 0, link at 1, CAF/CAP0 at 2
label = if globalIS state (toEnum fn) then GLOBAL else LOCAL
info = (fromJust . lookupIS state . toEnum) fn
name = show (profI info)
in -- Maybe use some other producer
case (unitS triple =>>> (if prof then addStatic fn fn else unitS 0)
=>>> (if funnames then
addString name (if prof then [label profproducer fn,label profconstructor fn] else [])
else
unitS undefined)
=>>> mapS gFix gs) (Down ) thread of
((plabel,slabel,gs),Thread state _ profstatics strings _ _ nbs bs nas as) ->
case uniqueIS state of
(clabel,state) ->
(capTable a ++
DATA_GLB consttable (fromEnum clabel) :
label fun fn :
(if tprof then tpgcode info state else []) ++
g:concat gs ++
ALIGN_CONST:
(case align 8 (-nbs * wsize) of
0 -> []
f -> take (f `div` wsize) (repeat (DATA_W 0))
) ++
bs ++
(if funnames then [DATA_W pos,DATA_GLB string slabel] else []) ++
LOCAL consttable (fromEnum clabel) :
DATA_CONSTHEADER (length as) a: -- number of pointers and arity
DATA_W 0: -- link for gc
(if a == 0 then [label caf fn, DATA_VAP fn] else [label cap0 fn, DATA_CAP fn a]) ++
compilerProfstatic prof state plabel ++
reverse as
,(prof,state,profstatics,strings))
--PHtprof
tpgcode :: Info -> IntState -> [Gcode]
tpgcode info state = let mod = fromEnum (miIS state)
sub = case info of
(InfoName _ _ _ _ True) -> tprofmodulesub
otherwise -> tprofmodule
in [DATA_GLB sub mod]
capTable a =
let fill = align wsize (2 * a + 2) `div` 2
-- one extra table item compared to arity
in take fill (repeat (DATA_CAPITEM 0 0)) ++ cT a a
where
cT a n =
if n>=0 then
DATA_CAPITEM (a-n) n : cT a (n-1)
else
[]
gUnique down thread@(Thread state prof profstatics strings live
labels nbs bs nas as) =
case uniqueIS state of
(u,state) -> (u,Thread state prof profstatics strings live
labels nbs bs nas as)
gState down thread@(Thread state prof profstatics strings live
labels nbs bs nas as) =
(state,thread)
gInfo i down thread@(Thread state prof profstatics strings live
labels nbs bs nas as) =
(lookupIS state i,thread)
useLabel i down thread@(Thread state prof profstatics strings live
labels nbs bs nas as) =
Thread state prof profstatics strings live (addM labels i) nbs bs nas as
ifLive f down thread@(Thread state prof profstatics strings live
labels nbs bs nas as) =
if live then
f down thread
else
([],thread)
emits g down thread@(Thread state prof profstatics strings live
labels nbs bs nas as) =
(g, thread)
emit g = emits [g]
conInfo i down thread@(Thread state prof profstatics strings live
labels nbs bs nas as) =
case lookupIS state i of
Just (InfoName u (TupleId a) t _ _) -> ((a,0),thread)
-- !!! NR the only constructors that can use InfoName is tuples !!!
--PHtprof
Just cinfo@(InfoConstr _ _ _ _ _ _ idata) ->
case lookupIS state idata of
Just info ->
((arityI cinfo,nthcon 0 i (constrsI info)),thread)
where
nthcon n con (c:cs) = if con == c then n else nthcon (n+1) con cs
nthcon n con [] =
error ("GcodeFix.nthcon: (n=="++show n++") (con=="++show con++") []\n")
addString str els down thread@(Thread state prof profstatics (strings,elabels) live labels nbs bs nas as) =
case lookupAT strings str of
Just l -> if null els then (l,thread)
else (l,Thread state prof profstatics (strings,map (pair l) els ++ elabels) live labels nbs bs nas as)
Nothing ->
case uniqueIS state of
(l,state) -> (fromEnum l,Thread state prof profstatics (addAT strings sndOf str (fromEnum l),map (pair (fromEnum l)) els ++ elabels) live labels nbs bs nas as)
addStatic p c down thread@(Thread state prof profstatics strings live labels nbs bs nas as) =
case lookupAT profstatics (p,c) of
Just l -> (l,thread)
Nothing ->
case uniqueIS state of
(l,state) -> (fromEnum l,Thread state prof (addAT profstatics sndOf (p,c) (fromEnum l)) strings live labels nbs bs nas as)
addDouble gs down thread = addBefore' True gs down thread
addBefore gs down thread = addBefore' False gs down thread
addBefore' align8 gs' down thread@(Thread state prof profstatics strings live labels nbs bs nas as) =
case search gs nbs bs of
Just nbs' -> (nbs',thread)
Nothing ->
let (nbs',bs') = if align8 then
let fill = align 8 (wsize * (-nbs)) `div` wsize
in (nbs-fill,take fill (repeat (DATA_W 0))++bs)
else
(nbs,bs)
nbs'' = nbs' - length gs
in (nbs'',Thread state prof profstatics strings live labels nbs'' (gs++bs') nas as)
where
-- We need module, producer (compiler?), and constructor !!!
gs = if prof then head gs' : DATA_W 0 : DATA_CREATE : DATA_W 0 : DATA_W 0 : tail gs' else gs'
eqInit [] _ = True
eqInit (a:as) (b:bs) = a == b && eqInit as bs
search gs nbs [] = Nothing
search gs nbs bbs@(b:bs) =
if eqInit gs bbs then Just nbs
else let nbs1 = nbs+1
in seq nbs1 (search gs nbs1 bs)
addAfter g down thread@(Thread state prof profstatics strings live labels nbs bs nas as) =
case search g nas as of
Just nas' -> (nas',thread)
Nothing ->
let nas' = nas + 1
in (nas',Thread state prof profstatics strings live labels nbs bs nas' (g:as))
where
search g nas [] = Nothing
search g nas (a:as) =
if g == a then Just nas
else let nas1 = nas-1
in seq nas1 (search g nas1 as)
gFix g@(NEEDHEAP i) = ifLive (emit g)
gFix g@(NEEDSTACK i) = ifLive (emit g)
gFix g@(LABEL i) = ifLive (emit g)
gFix g@(JUMP i) = ifLive (useLabel i >>> emit g)
gFix g@(JUMPFALSE i) = ifLive (useLabel i >>> emit g) -- DAVID
-- If this case isn't full, then defpop must be Just (def,pop) or we have an internal error
gFix g@(CASE alts defpop) = ifLive $
mapS0 (useLabel.snd) alts >>>
gUnique >>>= \ poplabel ->
case alts of
((GALT_CON c,_):_) ->
gInfo (toEnum c) >>>= \ coninfo ->
gInfo ((belongstoI . fromJust) coninfo) >>>= \ typeinfo ->
let constrs = (constrsI . fromJust) typeinfo
matched = map dropGALT alts
usedef = length constrs /= length matched
(def,pop) = fromJust defpop
ls = map (fromEnum . reorder poplabel matched . fromEnum)
constrs -- DAVID
in
(if usedef then useLabel def else unitS0) >>> -- DAVID
emits (TABLESWITCH (length ls) 0 ls : -- DAVID
(if usedef then -- DAVID
[LABEL (fromEnum poplabel), POP pop, JUMP def] -- DAVID
else -- DAVID
[]) -- DAVID
) -- DAVID
{-------------------- DAVID ---------------
(if usedef then useLabel def else unitS0) >>>
emits (MATCHCON : JUMPS_T : (map (JUMPTABLE . reorder poplabel matched) constrs) ++
(if usedef then
[LABEL poplabel, POP pop, JUMP def]
else
[]
)
)
----------- DAVID -------------------------- -}
((GALT_INT _,_):_) ->
let (def,pop) = fromJust defpop -- Never all contructors when matching ints
tls = map dropGALT alts in
emits (LOOKUPSWITCH (length tls) 0 tls (fromEnum poplabel) :
{------------ DAVID -------------------------
emits (MATCHINT : JUMPS_L : JUMPLENGTH (length alts) poplabel : map ( \ (GALT_INT i,l) -> JUMPLIST i l) alts ++
------------- DAVID -------------------- --}
[LABEL (fromEnum poplabel), POP pop, JUMP def]
)
where
dropGALT (GALT_CON c,l) = (c, toEnum l)
dropGALT (GALT_INT i,l) = (i, toEnum l)
reorder d ms c =
case lookup c ms of
Nothing -> d
Just l -> l
gFix g@(PRIMITIVE) = ifLive (emit g)
gFix g@(DATA_CREATE) = ifLive (emit g)
gFix g@(DATA_GLB string label) = ifLive (emit g)
gFix g@(DATA_CLABEL label) = ifLive (emit g)
gFix g@(DATA_FLABEL label) = ifLive (emit g)
gFix g@(MKIORETURN) = ifLive (emit g)
gFix g@(PRIM prim) = ifLive (emit g)
-- Stack
gFix g@(PUSH_INT i) = ifLive $
if i >= -10 && i < 256 then
emit g
else
addBefore [DATA_CONW 1 0,DATA_W i] >>>= \ i ->
emits [PUSH_CADR i, EVALUATED]
gFix g@(PUSH_CHAR i) = ifLive $
if i >= -10 && i < 256 then
emit g
else
addBefore [DATA_CONW 1 0,DATA_W i] >>>= \ i ->
emits [PUSH_CADR i, EVALUATED]
gFix g@(PUSH_INTEGER i) = ifLive $
addBefore (lowInteger i) >>>= \ i ->
emits [PUSH_CADR i, EVALUATED]
gFix g@(PUSH_FLOAT f) = ifLive $
addBefore [DATA_CONW 1 0,DATA_F f] >>>= \ i ->
emits [PUSH_CADR i, EVALUATED]
gFix g@(PUSH_DOUBLE d) = ifLive $
addDouble [DATA_CONW 2 0,DATA_D d,DATA_NOP] >>>= \ i ->
emits [PUSH_CADR i, EVALUATED]
gFix g@(PUSH_STRING s) = ifLive $
addString (escNul s) [] >>>= \ label ->
addBefore [DATA_CONW 1 0,DATA_GLB string label] >>>= \ i ->
emits [PUSH_CADR i, EVALUATED]
gFix g@(PUSH_ARG i) = ifLive (emit g)
gFix g@(PUSH_ZAP_ARG i) = ifLive (emit g)
gFix g@(PUSH i) = ifLive (emit g)
gFix g@(PUSH_HEAP ) = ifLive (emit g)
gFix g@(PUSH_GLB s i) = ifLive $
addAfter (DATA_GLB s i) >>>= \ i ->
emit (PUSH_CVAL i)
gFix g@(POP i) = ifLive (emit g)
gFix g@(SLIDE i) = ifLive (emit g)
gFix g@(UNPACK i) = ifLive (emit g)
-- selector
gFix g@(SELECTOR_EVAL) = ifLive (emit g)
gFix g@(SELECT i) = ifLive (emit g)
-- evaluation
gFix g@(APPLY i) = ifLive (emit g)
gFix g@(EVAL) = ifLive (emit g)
gFix g@(RETURN) = ifLive (emit g)
gFix g@(RETURN_EVAL) = ifLive (emit g)
-- Heap
gFix g@(HEAP_INT i) = ifLive $
if i >= -10 && i < 256 then
emit g
else
addBefore [DATA_CONW 1 0,DATA_W i] >>>= \ i ->
emit (HEAP_CADR i)
gFix g@(HEAP_CHAR i) = ifLive $
if i >= -1 && i < 256 then
emit g
else
addBefore [DATA_CONW 1 0,DATA_W i] >>>= \ i ->
emit (HEAP_CADR i)
gFix g@(HEAP_INTEGER i) = ifLive $
addBefore (lowInteger i) >>>= \ i ->
emit (HEAP_CADR i)
gFix g@(HEAP_FLOAT f) = ifLive $
addBefore [DATA_CONW 1 0,DATA_F f] >>>= \ i ->
emit (HEAP_CADR i)
gFix g@(HEAP_DOUBLE d) = ifLive $
addDouble [DATA_CONW 2 0,DATA_D d,DATA_NOP] >>>= \ i ->
emit (HEAP_CADR i)
gFix g@(HEAP_STRING s) = ifLive $
addString s [] >>>= \ label ->
addBefore [DATA_GLB string label] >>>= \ i ->
emit (HEAP_CVAL i)
gFix g@(HEAP_ARG i) = ifLive (emit g)
gFix g@(HEAP_ARG_ARG i j) = ifLive (emit g)
gFix g@(HEAP_ARG_ARG_RET_EVAL i j) = ifLive (emit g)
gFix g@(HEAP i) = ifLive (emit g)
gFix g@(HEAP_GLB s i) = ifLive $
addAfter (DATA_GLB s i) >>>= \ i ->
emit (HEAP_CVAL i)
gFix g@(HEAP_VAP i) = ifLive $
addAfter (DATA_VAP i) >>>= \ i ->
emits [HEAP_CVAL i]
gFix g@(HEAP_CON i) = ifLive $
conInfo (toEnum i) >>>= \ (s,c) ->
addBefore [DATA_CON s c] >>>= \ i ->
emits [HEAP_CVAL i]
gFix g@(HEAP_CAP i a) = ifLive $
addAfter (DATA_CAP i a) >>>= \ i ->
emits [HEAP_CVAL i]
gFix g@(HEAP_OFF i) = ifLive (emit g)
gFix g@(HEAP_STATIC p c) =
addStatic p c >>>= \ label ->
addBefore [DATA_GLB profstatic label] >>>= \ i ->
emit (HEAP_CVAL i)
gFix g@(HEAP_CREATE) = ifLive (emit g)
gFix g@(HEAP_SPACE) = ifLive (emit g)
gFix g@(EVALUATED) = ifLive (emit g)
gFix g =
gState >>>= \ state -> error ("gFix:" ++ strGcode state g)
|
